diff options
Diffstat (limited to 'gcc/cobol')
43 files changed, 8669 insertions, 5514 deletions
diff --git a/gcc/cobol/ChangeLog b/gcc/cobol/ChangeLog index 87aeaba..35d645c 100644 --- a/gcc/cobol/ChangeLog +++ b/gcc/cobol/ChangeLog @@ -1,3 +1,1185 @@ +2025-08-02 Jakub Jelinek <jakub@redhat.com> + + * parse.y (intrinsic): Use %td format specifier with no cast on + argument instead of %ld with cast to long. + * scan_ante.h (numstr_of): Likewise. + * util.cc (cbl_field_t::report_invalid_initial_value): Likewise. + +2025-08-01 Robert Dubner <rdubner@symas.com> + + PR cobol/119324 + * cbldiag.h (location_dump): Inline suppression of knownConditionTrueFalse. + * genapi.cc (parser_statement_begin): Combine two if() statements. + * genutil.cc (get_binary_value): File-level suppression of duplicateBreak. + * symbols.cc (symbol_elem_cmp): File-level suppression of duplicateBreak. + +2025-07-31 Robert Dubner <rdubner@symas.com> + + PR cobol/120244 + * genapi.cc (get_level_88_domain): Increase array size for final byte. + (psa_FldLiteralA): Use correct length in build_string_literal call. + * scan.l: Use a loop instead of std:transform to avoid EOF overrun. + * scan_ante.h (binary_integer_usage): Use a variable-length buffer. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * util.cc: Update for diagnostic_t becoming + enum class diagnostics::kind. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * util.cc: Update for renaming of diagnostic_option_id to + diagnostics::option_id. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * util.cc: Remove redundant #includes + +2025-07-24 Robert Dubner <rdubner@symas.com> + + PR cobol/119231 + * gcobolspec.cc: (lang_specific_driver): Pass OPT_static through. + Handle -static and -static-libgcobol properly. + +2025-07-23 Robert Dubner <rdubner@symas.com> + + * genapi.cc (leave_procedure): Adjust location_t for PERFORM. + (parser_perform_times): Likewise. + (internal_perform_through_times): Likewise. + (perform_outofline_before_until): Likewise. + (perform_outofline_after_until): Likewise. + (perform_outofline_testafter_varying): Likewise. + (perform_outofline_before_varying): Likewise. + +2025-07-21 Robert Dubner <rdubner@symas.com> + James K. Lowden <jklowden@cobolworx.com> + + PR cobol/120402 + * Make-lang.in: Elminate commented-out scripting. + * cbldiag.h (_CBLDIAG_H): Change #if 0 to #if GCOBOL_GETENV + (warn_msg): Add printf attributes. + (location_dump): Add debugging message. + * cdf.y: Improved linemap tracking. + * genapi.cc (treeplet_fill_source): const attribute for formal parameter. + (insert_nop): Created to consolidate var_decl_nop writes. + (build_main_that_calls_something): Move generation to the end of executable. + (level_88_helper): Formatting. + (parser_call_targets_dump): Formatting. + (function_pointer_from_name): const attribute for formal parameter. + (parser_initialize_programs): const attribute for formal parameter. + (parser_statement_begin): Improved linemap handling. + (section_label): Improved linemap handling. + (paragraph_label): Improved linemap handling. + (pseudo_return_pop): Improved linemap handling. + (leave_procedure): Formatting. + (parser_enter_section): Improved linemap handling. + (parser_enter_paragraph): Improved linemap handling. + (parser_perform): Formatting. + (parser_leave_file): Move creation of main() to this routine. + (parser_enter_program): Move creation of main from here to leave_file. + (parser_accept): Formatting. const attribute for formal parameter. + (parser_accept_command_line): const attribute for formal parameter. + (parser_accept_command_line_count): const attribute for formal parameter. + (parser_accept_envar): Likewise. + (parser_set_envar): Likewise. + (parser_display): Likewise. + (get_exhibit_name): Implement EXHIBIT verb. + (parser_exhibit): Likewise. + (parser_sleep): const attribute for formal parameter. + (parser_division): Improved linemap handling. + (parser_classify): const attribute for formal parameter. + (create_iline_address_pairs): Improved linemap handling. + (parser_perform_start): Likewise. + (perform_inline_until): Likewise. + (perform_inline_testbefore_varying): Likewise. + (parser_perform_until): Likewise. + (parser_perform_inline_times): Likewise. + (parser_intrinsic_subst): const attribute for formal parameter. + (parser_file_merge): Formatting. + (create_and_call): Improved linemap handling. + (mh_identical): const attribute for formal parameter. + (mh_numeric_display): const attribute for formal parameter. + (mh_little_endian): Likewise. + (mh_source_is_group): Likewise. + (psa_FldLiteralA): Formatting. + * genapi.h (parser_accept): const attribute for formal parameter. + (parser_accept_envar): Likewise. + (parser_set_envar): Likewise. + (parser_accept_command_line): Likewise. + (parser_accept_command_line_count): Likewise. + (parser_add): Likewise. + (parser_classify): Likewise. + (parser_sleep): Likewise. + (parser_exhibit): Likewise. + (parser_display): Likewise. + (parser_initialize_programs): Likewise. + (parser_intrinsic_subst): Likewise. + * gengen.cc (gg_assign): Improved linemap handling. + (gg_add_field_to_structure): Likewise. + (gg_define_from_declaration): Likewise. + (gg_build_relational_expression): Likewise. + (gg_goto_label_decl): Likewise. + (gg_goto): Likewise. + (gg_printf): Likewise. + (gg_fprintf): Likewise. + (gg_memset): Likewise. + (gg_memchr): Likewise. + (gg_memcpy): Likewise. + (gg_memmove): Likewise. + (gg_strcpy): Likewise. + (gg_strcmp): Likewise. + (gg_strncmp): Likewise. + (gg_return): Likewise. + (chain_parameter_to_function): Likewise. + (gg_define_function): Likewise. + (gg_get_function_decl): Likewise. + (gg_call_expr): Likewise. + (gg_call): Likewise. + (gg_call_expr_list): Likewise. + (gg_exit): Likewise. + (gg_abort): Likewise. + (gg_strlen): Likewise. + (gg_strdup): Likewise. + (gg_malloc): Likewise. + (gg_realloc): Likewise. + (gg_free): Likewise. + (gg_set_current_line_number): Likewise. + (gg_get_current_line_number): Likewise. + (gg_insert_into_assembler): Likewise. + (token_location_override): Likewise. + (gg_token_location): Likewise. + * gengen.h (location_from_lineno): Likewise. + (gg_set_current_line_number): Likewise. + (gg_get_current_line_number): Likewise. + (gg_token_location): Likewise. + (current_token_location): Likewise. + (current_location_minus_one): Likewise. + (current_location_minus_one_clear): Likewise. + (token_location_override): Likewise. + * genmath.cc (fast_divide): const attribute for formal parameter. + * genutil.cc (get_and_check_refstart_and_reflen): Likewise. + (get_data_offset): Likewise. + (refer_refmod_length): Likewise. + (refer_offset): Likewise. + (refer_size): Likewise. + (refer_size_dest): Likewise. + (refer_size_source): Likewise. + (qualified_data_location): Likewise. + * genutil.h (refer_offset): Likewise. + (refer_size_source): Likewise. + (refer_size_dest): Likewise. + (qualified_data_location): Likewise. + * parse.y: EVALUATE token; Implement EXHIBIT verb; + Improved linemap handling. + * parse_ante.h (input_file_status_notify): Improved linemap handling. + (location_set): Likewise. + * scan.l: PICTURE string validation. + * scan_ante.h (class picture_t): PICTURE string validation. + (validate_picture): Likewise. + * symbols.cc (symbol_currency): Revised default currency handling. + * symbols.h (symbol_currency): Likewise. + * util.cc (location_from_lineno): Improved linemap handling. + (current_token_location): Improved linemap handling. + (current_location_minus_one): Improved linemap handling. + (current_location_minus_one_clear): Improved linemap handling. + (gcc_location_set_impl): Improved linemap handling. + (warn_msg): Improved linemap handling. + * util.h (cobol_lineno): Improved linemap handling. + +2025-07-15 Jakub Jelinek <jakub@redhat.com> + Jason Merrill <jason@redhat.com> + + PR c/44677 + * gcobolspec.cc (lang_specific_driver): Remove unused but set variable + n_cobol_files. + +2025-07-14 Robert Dubner <rdubner@symas.com> + + * cobol1.cc (cobol_langhook_handle_option): Eliminate cppcheck warnings. + * dts.h: Likewise. + * except.cc (cbl_enabled_exceptions_t::dump): Likewise. + * gcobolspec.cc (lang_specific_driver): Likewise. + * genapi.cc (parser_file_merge): Likewise. + * gengen.cc (gg_unique_in_function): Likewise. + (gg_declare_variable): Likewise. + (gg_peek_fn_decl): Likewise. + (gg_define_function): Likewise. + * genmath.cc (set_up_on_exception_label): Likewise. + (set_up_compute_error_label): Likewise. + (arithmetic_operation): Likewise. + (fast_divide): Likewise. + * genutil.cc (get_and_check_refstart_and_reflen): Likewise. + (get_depending_on_value_from_odo): Likewise. + (get_data_offset): Likewise. + (get_binary_value): Likewise. + (process_this_exception): Likewise. + (copy_little_endian_into_place): Likewise. + (refer_is_clean): Likewise. + (refer_fill_depends): Likewise. + * genutil.h (process_this_exception): Likewise. + (copy_little_endian_into_place): Likewise. + (refer_is_clean): Likewise. + * lexio.cc (check_push_pop_directive): Likewise. + (check_source_format_directive): Likewise. + (location_in): Likewise. + (lexer_input): Likewise. + (cdftext::lex_open): Likewise. + (lexio_dialect_mf): Likewise. + (valid_sequence_area): Likewise. + (cdftext::free_form_reference_format): Likewise. + (cdftext::segment_line): Likewise. + * lexio.h (struct span_t): Likewise. + * scan_ante.h (trim_location): Likewise. + * symbols.cc (symbol_elem_cmp): Likewise. + (symbol_alphabet): Likewise. + (end_of_group): Likewise. + (cbl_field_t::attr_str): Likewise. + (symbols_update): Likewise. + (symbol_typedef_add): Likewise. + (symbol_field_add): Likewise. + (new_temporary_impl): Likewise. + (symbol_label_section_exists): Likewise. + (symbol_program_callables): Likewise. + (file_status_status_of): Likewise. + * symfind.cc (is_data_field): Likewise. + (finalize_symbol_map2): Likewise. + (class in_scope): Likewise. + (symbol_match2): Likewise. + * util.cc (get_current_dir_name): Likewise. + (gb4): Likewise. + (class cdf_directives_t): Likewise. + (cbl_field_t::report_invalid_initial_value): Likewise. + (literal_subscript_oob): Likewise. + (cbl_refer_t::str): Likewise. + (date_time_fmt): Likewise. + (class unique_stack): Likewise. + (cobol_set_pp_option): Likewise. + (cobol_filename): Likewise. + (cobol_filename_restore): Likewise. + (gcc_location_set_impl): Likewise. + (ydferror): Likewise. + (error_msg_direct): Likewise. + (yyerror): Likewise. + (cbl_unimplemented_at): Likewise. + +2025-07-13 Robert Dubner <rdubner@symas.com> + + * Make-lang.in: Eliminate the .cc.o override. + * genapi.cc (level_88_helper): Eliminate cppcheck warning. + (get_level_88_domain): Likewise. + (get_class_condition_string): Likewise. + (parser_call_targets_dump): Likewise. + (parser_compile_ecs): Likewise. + (initialize_variable_internal): Likewise. + (move_tree): Likewise. + (combined_name): Likewise. + (assembler_label): Likewise. + (find_procedure): Likewise. + (parser_perform): Likewise. + (parser_perform_times): Likewise. + (internal_perform_through): Likewise. + (internal_perform_through_times): Likewise. + (psa_FldLiteralN): Likewise. + (psa_FldBlob): Likewise. + (parser_accept): Likewise. + (parser_accept_exception): Likewise. + (parser_accept_exception_end): Likewise. + (parser_accept_command_line): Likewise. + (parser_accept_envar): Likewise. + (parser_display_internal): Likewise. + (parser_display): Likewise. + (parser_assign): Likewise. + (parser_initialize_table): Likewise. + (parser_arith_error): Likewise. + (parser_arith_error_end): Likewise. + (parser_division): Likewise. + (label_fetch): Likewise. + (parser_label_label): Likewise. + (parser_label_goto): Likewise. + (parser_perform_start): Likewise. + (parser_perform_conditional): Likewise. + (parser_perform_conditional_end): Likewise. + (parser_perform_until): Likewise. + (parser_file_delete): Likewise. + (parser_intrinsic_subst): Likewise. + (create_lsearch_address_pairs): Likewise. + (parser_bsearch_start): Likewise. + (is_ascending_key): Likewise. + (parser_sort): Likewise. + (parser_file_sort): Likewise. + (parser_return_start): Likewise. + (parser_file_merge): Likewise. + (parser_string_overflow): Likewise. + (parser_unstring): Likewise. + (parser_string): Likewise. + (parser_call_exception): Likewise. + (create_and_call): Likewise. + (mh_identical): Likewise. + (move_helper): Likewise. + (binary_initial_from_float128): Likewise. + (initial_from_initial): Likewise. + (psa_FldLiteralA): Likewise. + (parser_local_add): Likewise. + (parser_symbol_add): Likewise. + * genapi.h (parser_display): Likewise. + * gengen.cc (gg_call_expr): Explict check for NULL_TREE. + (gg_call): Likewise. + * show_parse.h (SHOW_PARSE_LABEL_OK): Likewise. + (TRACE1_FIELD_VALUE): Likewise. + (CHECK_FIELD): Likewise. + (CHECK_FIELD2): Likewise. + (CHECK_LABEL): Likewise. + * util.cc (cbl_internal_error): Apply [[noreturn]] attribute. + * util.h (cbl_internal_error): Likewise. + +2025-07-11 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + PR cobol/120621 + * lexio.cc (parse_replace_pairs): Cast mfile.lineno() to fmt_size_t. + * parse.y (intrinsic): Print ptrdiff_t using %ld, cast arg to long. + * scan_ante.h (numstr_of): Print nx using %ld, cast arg to long. + * util.cc (cbl_field_t::report_invalid_initial_value): Print + ptrdiff_t using %ld, cast arg to long. + +2025-07-10 James K. Lowden <jklowden@cobolworx.com> + + PR cobol/120765 + * cdf.y: Extend grammar for new CDF syntax, relocate dictionary. + * cdfval.h (cdf_dictionary): Use new CDF dictionary. + * dts.h: Remove useless assignment, note incorrect behavior. + * except.cc: Remove obsolete EC state. + * gcobol.1: Document CDF in its own section. + * genapi.cc (parser_statement_begin): Use new EC state function. + (parser_file_merge): Same. + (parser_check_fatal_exception): Same. + * genutil.cc (get_and_check_refstart_and_reflen): Same. + (get_depending_on_value_from_odo): Same. + (get_data_offset): Same. + (process_this_exception): Same. + * lexio.cc (check_push_pop_directive): New function. + (check_source_format_directive): Restrict regex search to 1 line. + (cdftext::free_form_reference_format): Use new function. + * parse.y: Define new CDF tokens, use new CDF state. + * parse_ante.h (cdf_tokens): Use new CDF state. + (redefined_token): Same. + (class prog_descr_t): Remove obsolete CDF state. + (class program_stack_t): Same. + (current_call_convention): Same. + * scan.l: Recognize new CDF tokens. + * scan_post.h (is_cdf_token): Same. + * symbols.h (cdf_current_tokens): Change current_call_convention to return void. + * token_names.h: Regenerate. + * udf/stored-char-length.cbl: Use new PUSH/POP CDF functionality. + * util.cc (class cdf_directives_t): Define cdf_directives_t. + (current_call_convention): Same. + (cdf_current_tokens): Same. + (cdf_dictionary): Same. + (cdf_enabled_exceptions): Same. + (cdf_push): Same. + (cdf_push_call_convention): Same. + (cdf_push_current_tokens): Same. + (cdf_push_dictionary): Same. + (cdf_push_enabled_exceptions): Same. + (cdf_push_source_format): Same. + (cdf_pop): Same. + (cdf_pop_call_convention): Same. + (cdf_pop_current_tokens): Same. + (cdf_pop_dictionary): Same. + (cdf_pop_enabled_exceptions): Same. + (cdf_pop_source_format): Same. + * util.h (cdf_push): Declare cdf_directives_t. + (cdf_push_call_convention): Same. + (cdf_push_current_tokens): Same. + (cdf_push_dictionary): Same. + (cdf_push_enabled_exceptions): Same. + (cdf_push_source_format): Same. + (cdf_pop): Same. + (cdf_pop_call_convention): Same. + (cdf_pop_current_tokens): Same. + (cdf_pop_dictionary): Same. + (cdf_pop_source_format): Same. + (cdf_pop_enabled_exceptions): Same. + +2025-07-09 Robert Dubner <rdubner@symas.com> + James K. Lowden <jklowden@cobolworx.com> + + PR cobol/120765 + PR cobol/119337 + PR cobol/120794 + * Make-lang.in: Take control of the .cc.o rule. + * cbldiag.h (error_msg_direct): New declaration. + (gcc_location_dump): Forward declaration. + (location_dump): Use gcc_location_dump. + * cdf.y: Change some tokens. + * gcobc: Change dialect handling. + * genapi.cc (parser_call_targets_dump): Temporarily remove from service. + (parser_compile_dcls): Combine temporary arrays. + (get_binary_value_from_float): Apply const to one parameter. + (depending_on_value): Localize a boolean variable. + (normal_normal_compare): Likewise. + (cobol_compare): Eliminate cppcheck warning. + (combined_name): Apply const to an input parameter. + (parser_perform): Apply const to a variable. + (parser_accept): Improve handling of special_name_t parameter and + the exception conditions. + (parser_display): Improve handling of speciat_name_t parameter; use the + os_filename[] string when appropriate. + (program_end_stuff): Rename shadowing variable. + (parser_division): Consolidate temporary char[] arrays. + (parser_file_start): Apply const to a parameter. + (inspect_replacing): Likewise. + (parser_program_hierarchy): Rename shadowing variable. + (mh_identical): Apply const to parameters. + (float_type_of): Likewise. + (picky_memcpy): Likewise. + (mh_numeric_display): Likewise. + (mh_little_endian): Likewise. + (mh_source_is_group): Apply static to a variable it. + (move_helper): Quiet a cppcheck warning. + * genapi.h (parser_accept): Add exceptions to declaration. + (parser_accept_under_discussion): Add declaration. + (parser_display): Change to std::vector; add exceptions to declaration. + * lexio.cc (cdf_source_format): Improve source code location handling. + (source_format_t::infer): Likewise. + (is_fixed_format): Likewise. + (is_reference_format): Likewise. + (left_margin): Likewise. + (right_margin): Likewise. + (cobol_set_indicator_column): Likewise. + (include_debug): Likewise. + (continues_at): Likewise. + (indicated): Likewise. + (check_source_format_directive): Likewise. + (cdftext::free_form_reference_format): Likewise. + * parse.y: Tokens; program and function names; DISPLAY and ACCEPT + handling. + * parse_ante.h (class tokenset_t): Removed. + (class current_tokens_t): Removed. + (field_of): Removed. + * scan.l: Token handling. + * scan_ante.h (level_found): Comment. + * scan_post.h (start_condition_str): Remove cast author_state:. + * symbols.cc (symbols_update): Change error message. + (symbol_table_init): Correct and reorder entries. + (symbol_unresolved_file_key): New function definition. + (cbl_file_key_t::deforward): Change error message. + * symbols.h (symbol_unresolved_file_key): New declaration. + (keyword_tok): New function. + (redefined_token): New function. + (class current_tokens_t): New class. + * symfind.cc (symbol_match): Revise error message. + * token_names.h: Reorder and change numbers in comments. + * util.cc (class cdf_directives_t): New class. + (cobol_set_indicator_column): New function. + (cdf_source_format): New function. + (gcc_location_set_impl): Improve column handling in token_location. + (gcc_location_dump): New function. + (class temp_loc_t): Modify constructor. + (error_msg_direct): New function. + * util.h (class source_format_t): New class. + +2025-07-01 James K. Lowden <jklowden@cobolworx.com> + + * Make-lang.in: Use && instead of semicolon between commands. + +2025-07-01 Robert Dubner <rdubner@symas.com> + + * parse.y: printf() of size_t is %zu, not %ld. + +2025-06-30 James K. Lowden <jklowden@cobolworx.com> + + PR cobol/120772 + PR cobol/120779 + PR cobol/120790 + PR cobol/120791 + PR cobol/120794 + * gcobc: Supply -fPIC for shared objects. + * genapi.cc (linemap_add): Delete empty macro. + (parser_enter_file): Do not call linemap_add. + (parser_leave_file): Same. + * gengen.cc (location_from_lineno): Remove function. + * lexio.cc (parse_replacing_term): Allow empty term. + (cdftext::process_file): Always append to output. + (cdftext::segment_line): Output #line directives. + * lexio.h (struct span_t): Count lines in span. + * parse.y: Revamp REPOSITORY, and minor syntax extensions. + * parse_ante.h (input_file_status_notify): Update linemap filename before location. + (intrinsic_token_of): Declare. + (parser_move_carefully): Support MOVE pointer. + * parse_util.h (intrinsic_token_of): New function. + * scan.l: New EOF logic, accept NOT=, own yylloc and yylineno. + * scan_ante.h (class enter_leave_t): Do not store newline count. + (cdf_location_set): Remove declaration. + (ydfltype_of): New function. + (update_location): Accept location parameter. + (reset_location): New function. + (YY_USER_ACTION): Use update_location(). + (YY_USER_INIT): Update CDF location. + (verify_ws): New function. + (wait_for_the_child): Removed. + * symbols.h (cobol_fileline_set): return line number. + * util.cc (valid_move): Use range-based for loop. + (struct input_file_t): Remove line_map pointer. + (class unique_stack): New peek() member function. + (cobol_lineno_save): Rename to overload cobol_lineno(). + (cobol_lineno): Replaces cobol_lineno_save(). + (cobol_filename): Return void. + (location_from_lineno): New function used by genapi.cc. + (cdf_location_set): Remove. + (matched_length): No change. + (cobol_fileline_set): Return line number. + (fisspace): Remove extra semicolon. + (fisprint): Same. + * util.h (cobol_filename_restore): Return void. + (cobol_lineno_save): Remove declaration. + (cobol_lineno): Declare. + +2025-06-29 Robert Dubner <rdubner@symas.com> + + * Make-lang.in: Incorporate gcobol.clean. + * except.cc (cbl_enabled_exceptions_t::dump): Update debug message. + * genapi.cc (gg_attribute_bit_get): Formatting. + (file_static_variable): Formatting. + (trace1_init): Formatting. + (build_main_that_calls_something): Normalize function_decl use. + (parser_call_target): Likewise. + (set_call_convention): Likewise. + (parser_call_target_convention): Likewise. + (parser_call_targets_dump): Likewise. + (function_handle_from_name): Likewise. + (function_pointer_from_name): Likewise. + (parser_initialize_programs): Likewise. + (parser_statement_begin): Formatting. + (parser_leave_file): Use function_decl FIFO. + (enter_program_common): Normalize function_decl use. + (parser_enter_program): Normalize function_decl use. + (tree_type_from_field_type): Normalize function_decl use. + (is_valuable): Comment. + (pe_stuff): Change name to program_end_stuff. + (program_end_stuff): Likewise. + (parser_exit): Likewise. + (parser_division): Normalize function_decl use. + (create_and_call): Normalize function_decl use. + (parser_call): Normalize function_decl use. + (parser_set_pointers): Normalize function_decl use. + (parser_program_hierarchy): Normalize function_decl use. + (psa_FldLiteralA): Defeat attempt to re-use literals. (Fails on some aarch64). + (parser_symbol_add): Error message formatting. + * genapi.h: Formatting. + * gengen.cc (struct cbl_translation_unit_t): Add function_decl FIFO. + (show_type): Rename to gg_show_type. + (gg_show_type): Correct an error message. + (gg_assign): Formatting; change error handling. + (gg_modify_function_type): Normalize function_decl use. + (gg_define_function_with_no_parameters): Fold into gg_defint_function(). + (function_decl_key): Normalize function_decl use. + (gg_peek_fn_decl): Normalize function_decl use. + (gg_build_fn_decl): Normalize function_decl use. + (gg_define_function): Normalize function_decl use. + (gg_tack_on_function_parameters): Remove. + (gg_finalize_function): Normalize function_decl use. + (gg_leaving_the_source_code_file): Normalize function_decl use. + (gg_call_expr_list): Normalize function_decl use. + (gg_trans_unit_var_decl): Normalize function_decl use. + (gg_insert_into_assemblerf): New function; formatting. + * gengen.h (struct gg_function_t): Eliminate "is_truly_nested" flag. + (gg_assign): Incorporate return value. + (gg_define_function): Normalize function_decl use. + (gg_define_function_with_no_parameters): Eliminate. + (gg_build_fn_decl): Normalize function_decl use. + (gg_peek_fn_decl): Normalize function_decl use. + (gg_modify_function_type): Normalize function_decl use. + (gg_call_expr_list): Normalize function_decl use. + (gg_get_function_decl): Normalize function_decl use. + (location_from_lineno): Prefix with "extern". + (gg_open): Likewise. + (gg_close): Likewise. + (gg_get_indirect_reference): Likewise. + (gg_insert_into_assembler): Likewise. + (gg_insert_into_assemblerf): Likewise. + (gg_show_type): New declaration. + (gg_leaving_the_source_code_file): New declaration. + * parse.y: Format debugging message. + * parse_ante.h: Normalize function_decl use. + +2025-06-20 James K. Lowden <jklowden@cobolworx.com> + + PR cobol/120621 + * genapi.cc (parser_compile_ecs): Cast argument to unsigned long. + (parser_compile_dcls): Same. + (parser_division): RAII. + (inspect_tally): Cast argument to unsigned long. + * lexio.cc (cdftext::lex_open): Cast pid_t to long. + * parse.y: hard-code values for old versions of Bison, and message format. + * scan_ante.h (wait_for_the_child): Cast pid_t to long. + +2025-06-18 James K. Lowden <jklowden@cobolworx.com> + + PR cobol/120621 + * cbldiag.h (yyerror): Add diagnostic attributes. + (yywarn): Same. + (error_msg): Same. + (yyerrorvl): Same. + (cbl_unimplementedw): Same. + (cbl_unimplemented): Same. + (cbl_unimplemented_at): Same. + * cdf-copy.cc (copybook_elem_t::open_file): Supply string argument. + * cdf.y: Use %<%>. + * cobol-system.h (if): Check GCC_VERSION. + (ATTRIBUTE_GCOBOL_DIAG): Define. + * except.cc (cbl_enabled_exception_t::dump): Remove extra %s. + * genapi.cc (get_class_condition_string): Use acceptable message. + (get_bytes_needed): Same. + (move_tree): Same. + (get_string_from): Same. + (internal_perform_through): Same. + (tree_type_from_field_type): Same. + (is_valuable): Same. + (parser_logop): Same. + (parser_relop): Same. + (parser_relop_long): Same. + (parser_if): Same. + (parser_setop): Same. + (parser_perform_conditional): Same. + (parser_file_add): Same. + (parser_file_open): Same. + (parser_file_close): Same. + (parser_file_read): Same. + (parser_file_write): Same. + (inspect_replacing): Same. + (parser_sort): Same. + (parser_file_sort): Same. + (parser_file_merge): Same. + (create_and_call): Same. + (parser_bitop): Same. + (parser_bitwise_op): Same. + (hijack_for_development): Same. + (mh_source_is_literalN): Same. + (mh_dest_is_float): Same. + (parser_symbol_add): Same. + * gengen.cc (show_type): Use acceptable message. + (gg_find_field_in_struct): Same. + (gg_declare_variable): Same. + (gg_printf): Same. + (gg_fprintf): Same. + (gg_tack_on_function_parameters): Same. + (gg_define_function): Same. + (gg_get_function_decl): Same. + (gg_finalize_function): Same. + (gg_call_expr): Same. + (gg_call): Same. + (gg_insert_into_assembler): Define new function. + (gg_insert_into_assemblerf): Use gg_insert_into_assembler(). + * gengen.h (gg_insert_into_assembler): Simpler function declaration. + (gg_insert_into_assemblerf): Declare new function. + * genmath.cc (parser_op): Use acceptable message. + * genutil.cc (get_binary_value): Use acceptable message. + * lexio.cc (parse_replacing_pair): Correct diagnostic arguments. + (preprocess_filter_add): Same. + (cdftext::open_input): Same. + * parse.y: Use acceptable messages. + * parse_ante.h (struct evaluate_elem_t): Use %<%>. + (is_callable): Same. + * parse_util.h (intrinsic_invalid_parameter): Use %qs. + * scan.l: Use dialect_error(). + * scan_ante.h (numstr_of): Use %qs. + (scanner_token): Quote COBOL tokens in messages. + (scanner_parsing): Correct diagnostic message. + (scanner_parsing_toggle): Quote COBOL tokens in messages. + (scanner_parsing_pop): Same. + (typed_name): Use %qs. + * scan_post.h (prelex): Quote COBOL tokens in message. + * show_parse.h (CHECK_FIELD): Use acceptable message format. + (CHECK_LABEL): Same. + * symbols.cc (symbol_field_same_as): Remove extra spaces. + (cbl_alphabet_t::assign): Use %<%>. + (cbl_field_t::internalize): Quote library name in message. + * symbols.h (struct os_locale_t): Constify codeset. + (class temporaries_t): Add copy constructor. + (struct cbl_alphabet_t): Use acceptable message. + * util.cc (symbol_type_str): Use cbl_internal_error. + (cbl_field_type_str): Same. + (is_elementary): Same. + (cbl_field_t::report_invalid_initial_value): Use %qs. + (class unique_stack): Avoid %m. + (ydferror): Declare function with attributes. + (error_msg): Same. + (cobol_fileline_set): Use %<%>. + (os_locale_t): Remove use of xstrdup. + (cobol_parse_files): Quote C names in message. + (dialect_error): Use %<%>. + * util.h (cbl_message): Add attributes. + (cbl_internal_error): Same. + (cbl_err): Same. + (cbl_errx): Same. + +2025-06-16 James K. Lowden <jklowden@cobolworx.com> + + PR cobol/120621 + * Make-lang.in: Use STRICT_WARN. + * cbldiag.h (location_dump): suppress shadowVariable. + * cdf-copy.cc (esc): Fix shadowVariable. + (copybook_elem_t::open_file): Do not use %m. + * cdf.y: suppress invalidPrintfArgType for target format. + * cdfval.h (struct cdfval_t): Suppress noExplicitConstructor. + * cobol1.cc (cobol_name_mangler): Use C++ cast. + * copybook.h (class copybook_elem_t): Same. + * dts.h: Fixes and suppressions due to cppcheck. + * except.cc (cbl_enabled_exceptions_t::status): Suppress useStlAlgorithm. + (cbl_enabled_exceptions_t::turn_on_off): Const parameter. + (class choose_declarative): Removed. + * genapi.cc (struct called_tree_t): Explicit constructor. + (parser_compile_ecs): Cast to void * for %p. + (parser_compile_dcls): Same. + (parser_statement_begin): Same. + (initialize_variable_internal): Use std::vector for subscripts. + (parser_initialize): Constification. + (get_string_from): Same. + (combined_name): Same. + (parser_perform): Same. + (psa_FldLiteralN): Same. + (is_figconst): Const parameter. + (is_figconst_t): Same. + (parser_exit): Same. + (parser_division): Const pointer. + (parser_perform_conditional): Whitespace. + (parser_set_conditional88): Const parameter. + (inspect_tally): Use std::vector. + (inspect_replacing): Same. + (parser_inspect): Same. + (parser_intrinsic_subst): Use std::vector (constuct elements). + (parser_intrinsic_call_1): Use std::vector for subscripts. + (is_ascending_key): Const pointer. + (parser_sort): Use std::vector. + (parser_file_sort): Same. + (parser_file_merge): Same. + (parser_unstring): Same. + (parser_string): Same. + (parser_call): Const pointer. + (parser_program_hierarchy): Use std::vector. + (conditional_abs): Const paraemeter. + (float_type_of): Same. + (initial_from_initial): Set value, quoted or not. + (parser_symbol_add): Remove redundant nested test. + * genapi.h (parser_add): Const parameters. + (parser_subtract): Same. + (parser_multiply): Same. + (parser_divide): Same. + (parser_perform): Same. + (parser_exit): Same. + (parser_initialize): Same. + (parser_set_conditional88): Same. + (parser_sort): Same. + (parser_file_sort): Same. + (parser_file_merge): Same. + (parser_string): Same. + (is_ascending_key): Same. + * genmath.cc (arithmetic_operation): Use std::vector. + (is_somebody_float): Const parameter. + (all_results_binary): Const parameter. + (fast_multiply): Remove redundant nested test. + (parser_add): Const parameter. + (parser_multiply): Remove redundant nested test. + (parser_divide): Const parameter. + (parser_subtract): Same. + * genutil.cc (get_depending_on_value): Use std::vector. + (get_data_offset): Same. + (tree_type_from_field): Const parameter. + (refer_has_depends): Const pointers. + (get_literal_string): RAII. + (refer_is_clean): Use std::vector. + (get_time_nanoseconds): Newline at EOF. + * genutil.h (tree_type_from_field): Remove declaration. + * inspect.h (struct cbx_inspect_qual_t): Use std::vector. + (struct cbl_inspect_qual_t): Same. + (struct cbx_inspect_match_t): Same. + (class cbl_inspect_match_t): Same. + (struct cbx_inspect_replace_t): Same. + (struct cbl_inspect_replace_t): Same. + (struct cbx_inspect_oper_t): Same. + (struct cbl_inspect_oper_t): Same. + (struct cbx_inspect_t): Same. + (struct cbl_inspect_t): Same. + (parser_inspect): Same. + * lexio.cc (indicated): Const pointer. + (remove_inline_comment): Scope reduction. + (maybe_add_space): Const pointer. + (recognize_replacements): C++ cast. + (check_source_format_directive): Same. + (struct replacing_term_t): Explicit constructor. + (parse_replace_pairs): Const reference. + (location_in): Const reference. + (parse_copy_directive): C++ cast. + (parse_replace_last_off): Const parameter. + (parse_replace_text): Const reference. + (parse_replace_directive): C++ cast. + (cdftext::lex_open): Const reference. + (cdftext::open_output): Scope reduction. + (cdftext::free_form_reference_format): Remove unused variable. + (cdftext::process_file): Simplify. + * lexio.h (struct bytespan_t): Use nullptr. + (struct filespan_t): Initialize icol in constructor. + (struct span_t): Suppress confused operatorEqRetRefThis. + (struct replace_t): Eliminate single-value constructor. + * parse.y: Many const cppcheck reports, and portable bit-shift. + * parse_ante.h (reject_refmod): Const parameter. + (require_pointer): Same. + (require_integer): Same. + (struct evaluate_elem_t): Explicit constructor. + (struct arith_t): Use std::vector. + (class eval_subject_t): Const parameter. + (dump_inspect_match): Declare. + (struct perform_t): Explicit constructor. + (list_add): Const parameter. + (class tokenset_t): Avoid negative array index. + (struct file_list_t): Explicit constructor. + (struct field_list_t): Same. + (struct refer_list_t): Same. + (struct refer_marked_list_t): Const parameter. + (struct refer_collection_t): Explicit constructor. + (struct ast_inspect_oper_t): Remove class. + (ast_inspect_oper_t): Same. + (struct ast_inspect_t): Same. + (struct ast_inspect_list_t): Same. + (ast_inspect): Add location. + (struct elem_list_t): Explicit constructor. + (struct unstring_tgt_t): Same. + (struct unstring_tgt_list_t): Same. + (struct unstring_into_t): Same. + (struct ffi_args_t): Same. + (struct file_sort_io_t): Same. + (merge_t): Same. + (struct vargs_t): Same. + (class prog_descr_t): Eliminate single-value constructor. + (class program_stack_t): Suppress useStlAlgorithm. + (struct rel_part_t): Eliminate single-value constructor. + (class log_expr_t): Explicit constructor. + (add_debugging_declarative): Rename local variable. + (intrinsic_call_2): Const parameter. + (invalid_key): Use std::find_if. + (parser_add2): Const parameter. + (parser_subtract2): Same. + (stringify): Same. + (unstringify): Same. + (anybody_redefines): Same. + (ast_call): Same. + * parse_util.h (class cname_cmp): Explicit constructor. + (intrinsic_inconsistent_parameter): Same. + * scan_ante.h (struct cdf_status_t): Eliminate single-value constructor. + (class enter_leave_t): Explicit constructor. + (update_location): Const pointer, explicit constructor. + (symbol_function_token): Const pointer. + (typed_name): Same. + * scan_post.h (datetime_format_of): Scope reduction. + * show_parse.h (class ANALYZE): Use std::vector, explicit consstructor. + * symbols.cc (symbol_table_extend): Scope reduction. + (cbl_ffi_arg_t::cbl_ffi_arg_t): Define default constructor. + (end_of_group): Const pointer. + (symbol_find_odo): Const parameter. + (rename_not_ok): Same. + (field_str): Use %u instead of %d. + (struct capacity_of): Const pointer. + (symbols_update): Same. + (symbol_field_parent_set): Same. + (symbol_file_add): Same. + (symbol_typedef_add): Same. + (symbol_field_add): Use new operator=(). + (symbol_field): Suppress CastIntegerToAddressAtReturn. + (symbol_register): Same. + (symbol_file): Suppress knownConditionTrueFalse. + (next_program): Const parameter. + (symbol_file_record): Same. + (class is_section): Explicit constructor. + (cbl_file_t::no_key): Remove. + (cbl_prog_hier_t::cbl_prog_hier_t): Use std::vector. + (symbol_label_add): Assert pointer is not NULL. + (symbol_label_section_exists): Const reference in lambda. + (expand_picture): Use C++ cast. + (symbol_program_callables): Const pointer. + (symbol_currency_add): Suppress nullPointerRedundantCheck. + (cbl_key_t): Use std::vector. + (cbl_occurs_t::field_add): Const parameter. + (cbl_occurs_t::index_add): Explicit constructor. + (class is_field_at): Same. + (cbl_file_key_t::deforward): Scope reduction. + (cbl_file_t::keys_str): Use allocated memory only. + (file_status_status_of): Const pointer. + (is_register_field): Const parameter. + * symbols.h (struct cbl_field_data_t): Eliminate single-value constructor. + (struct cbl_occurs_bounds_t): Same. + (struct cbl_refer_t): Use std::vector. + (valid_move): Const parameter. + (is_register_field): Same. + (struct cbl_key_t): Use std::vector. + (struct cbl_substitute_t): Eliminate single-value constructor. + (refer_of): Return const reference + (struct cbl_ffi_arg_t): Eliminate single-value constructor. + (class temporaries_t): Same. + (struct cbl_file_key_t): Define default constructor. + (struct cbl_file_lock_t): Define copy constructor and operator=(). + (struct cbl_file_t): Complete default constructor. + (struct symbol_elem_t): Explicit constructor. + (symbol_elem_of): Suppress cstyleCast. + (symbol_redefines): Const parameter. + (struct cbl_field_t): Same. + (cbl_section_of): Test for NULL pointer. + (cbl_field_of): Same. + (cbl_label_of): Same. + (cbl_special_name_of): Same. + (cbl_alphabet_of): Same. + (cbl_file_of): Same. + (is_figconst): Delete extra "struct" keyword. + (is_figconst_low): Same. + (is_figconst_zero): Same. + (is_figconst_space): Same. + (is_figconst_quote): Same. + (is_figconst_high): Same. + (is_space_value): Same. + (is_quoted): Same. + (symbol_index): Const parameter. + (struct cbl_prog_hier_t): Suppress noExplicitConstructor. + (struct cbl_perform_vary_t): Eliminate single-value constructor. + (is_signable): Const parameter. + (is_temporary): Same. + (rename_not_ok): Same. + (field_at): Test for NULL pointer. + (class procref_base_t): Eliminate single-value constructor. + * symfind.cc (is_data_field): Const pointer. + (finalize_symbol_map2): Same. + (class in_scope): Same. + (symbol_match2): Same. + * token_names.h: Suppress useInitializationList. + * util.cc (normalize_picture): Whitespace and remove extra "continue". + (redefine_field): Const pointer. + (cbl_field_t::report_invalid_initial_value): Same. + (literal_subscript_oob): Rename shadow variable. + (cbl_refer_t::subscripts_set): Use std::vector. + (cbl_refer_t::str): Same. + (cbl_refer_t::deref_str): Same. + (locally_unique): Use explicit constructor. + (ambiguous_reference): Same. + (class unique_stack): Use const reference. + (cobol_filename): Const pointer. + (verify_format): Scope reduction. + (class temp_loc_t): Do not derive from YYLTYPE. + (cobol_parse_files): Const pointer. + * util.h (as_voidp): Define convenient converter. + +2025-06-10 James K. Lowden <jklowden@cobolworx.com> + + * Make-lang.in: cobol.clean does not remove libgcobol files. + * cdf.y: Suppress 1 cppcheck false positive. + * cdfval.h (scanner_parsing): Partial via cppcheck for PR119324. + * gcobol.1: Fix groff errors. + * gcobolspec.cc (append_arg): Const parameter. + * parse_ante.h (intrinsic_call_2): Avoid NULL dereference. + +2025-06-06 Robert Dubner <rdubner@symas.com> + James K. Lowden <jklowden@cobolworx.com> + + PR cobol/120328 + PR cobol/119695 + * Make-lang.in: Success with non-English locale. + * cbldiag.h (cbl_unimplemented_at): Comment: + * cdf-copy.cc (copybook_elem_t::open_file): Indentation. + * cdf.y: YYABORT on certain errors. + * cdfval.h (cdf_value): Const parameter. + * copybook.h (class copybook_elem_t): Initialization. + (class uppername_t): Explicit constructor. + * except.cc (ec_type_descr): Remove %04s. + (cbl_enabled_exceptions_t::dump): Remove %zu. + * exceptg.h (class exception_turn_t): Explicit constructor. + * genapi.cc (parser_perform_conditional): Remove %zu. + (set_exception_environment): Formatting. + (parser_statement_begin): Exception overhead. + (parser_perform_conditional): Formatting: + (parser_perform_conditional_end): Eliminate size_t. + (parser_check_fatal_exception): Exception overhead. + (parser_perform_conditional_end): Remove %zu. + * inspect.h (struct cbx_inspect_match_t): Const reference. + (struct cbx_inspect_t): Const parameter. + * lexio.cc (cdftext::process_file): Remove %zu. + * lexio.h (struct YYLTYPE): Remove unneeded struct. + (YYLTYPE_IS_DECLARED): Likewise. + (YYLTYPE_IS_TRIVIAL): Likewise. + * parse.y: Comment; change DOT. + * scan.l: Scan function names without swallowing whitespace. + * scan_ante.h (scanner_parsing): Remove %zu. + (scanner_parsing_pop): Remove %zu. + (binary_integer_usage): Remove %zu. + * scan_post.h (prelex): Correct post-CDF resumption. + (yylex): Clearer message. + * symbols.cc (symbol_table_extend): Explicit constructor. + (elementize): Const parameter. + (is_variable_length): Correct always-false. + (symbols_update): Remove unnecessary shadow variable. + (struct symbol_elem_t): Const parameter. + (symbol_alphabet_add): Const parameter. + (new_literal_add): Initialization. + * symbols.h (class cbl_domain_elem_t): Correct assignment. + (struct cbl_span_t): Improve constructor. + (struct cbl_refer_t): Initialization. + (struct cbl_alphabet_t): Rename shadow variable. + (struct cbl_file_key_t): Remove unused constructor. + (struct symbol_elem_t): Initialization. + (struct cbl_until_addresses_t): Use unsigned int, for messages. + (struct cbl_prog_hier_t): Initialization. + (struct cbl_perform_tgt_t): Repair constructor. + (struct cbl_label_t): Const parameter. + (symbol_typedef_add): Const parameter. + (symbol_field_add): Explicit constructor. + (symbol_label_add): Explicit constructor. + (symbol_program_add): Remove C-style "struct" use. + (symbol_special_add): Remove C-style "struct" use. + (symbol_alphabet_add): Const parameter. + (symbol_file_add): Remove C-style "struct" use. + (symbol_section_add): Remove C-style "struct" use. + * symfind.cc: Const parameter. + * util.cc (gb4): New function. + * util.h (gb4): New function. + * TODO: New file. + +2025-06-05 Robert Dubner <rdubner@symas.com> + + PR cobol/119975 + * genapi.cc (parser_intrinsic_call_0): Use get_time_nanoseconds(). + * genutil.cc (get_time_64): Rename to get_time_nanoseconds(). + (get_time_nanoseconds): Likewise. + * genutil.h (get_time_64): Likewise. + (get_time_nanoseconds): Likewise. + * util.cc (class cbl_timespec): Timing routine uses + get_time_nanoseconds(). + (operator-): Likewise. + (parse_file): Likewise. + +2025-06-02 Robert Dubner <rdubner@symas.com> + + PR cobol/119975 + * genapi.cc (parser_intrinsic_call_0): Use get_time_64() function. + * genutil.cc (get_time_64): Definition created. + * genutil.h (get_time_64): Declaration created. + +2025-06-01 Robert Dubner <rdubner@symas.com> + + PR cobol/119524 + * gengen.cc (gg_printf): Use the new __gg__fprintf_stderr() function + instead of generating a call to fprintf(). + +2025-05-20 Robert Dubner <rdubner@symas.com> + James K. Lowden <jklowden@cobolworx.com> + + PR cobol/119770 + PR cobol/119772 + PR cobol/119790 + PR cobol/119771 + PR cobol/119810 + PR cobol/119335 + PR cobol/119632 + * cdf-copy.cc (GLOB_BRACE): Eliminate <glob.h>. + * cdfval.h (_CDF_VAL_H_): Switch to C++ headers. + * copybook.h (class copybook_elem_t): Eliminate <glob.h>. + (class copybook_t): Likewise. + * gcobc: Numerous changes to improve utility. + * gcobol.1: Correct names in the list of functions. + * genapi.cc (compare_binary_binary): Use has_attr() function. + * lexio.cc (cdftext::lex_open): Typo; filename logic. + (cdftext::process_file): Filename logic. + * parse.y: Numerous parsing changes. + * parse_ante.h (new_alphanumeric): C++ includes; changes to temporaries. + (new_tempnumeric): Likewise. + (new_tempnumeric_float): Likewise. + (set_real_from_capacity): Created. + * scan.l: Use yy_pop_state(). + * scan_ante.h (typed_name): Find figconst from data.initial. + * symbols.cc (symbol_valid_udf_args): Eliminate. + (symbols_update): figconst processing. + (new_temporary_impl): For functions, set .initial to function name. + (temporaries_t::acquire): Likewise. + (new_alphanumeric): Likewise. + (new_temporary): Likewise. + * symbols.h (_SYMBOLS_H_): Use C++ includes. + (cbl_figconst_tok): Change handling of figconst. + (cbl_figconst_field_of): Change handling of figconst. + (symbol_valid_udf_args): Eliminate. + * symfind.cc (symbol_match2): Change declaration. + (symbol_match): Change declaration. + +2025-05-18 Mark Wielaard <mark@klomp.org> + + * lang.opt.urls: Regenerated. + +2025-05-16 Robert Dubner <rdubner@symas.com> + + * cobol1.cc (cobol_langhook_handle_option): Eliminate OPT_M. + * except.cc (cbl_enabled_exception_t::dump): Formatting. + (symbol_declaratives_add): Remove. + (declarative_runtime_match): Change to no-blob processing. + * exceptg.h (declarative_runtime_match): Change declaration. + (symbol_declaratives_add): Remove declaration. + * gcobc: Dialect handling. + * genapi.cc (parser_compile_ecs): Formatting; add SHOW_IF_PARSE. + (parser_compile_dcls): Likewise. + (parser_statement_begin): Avoid unnecessary store_location_stuff() call. + (gg_get_depending_on_value): Streamline get_depending_on_value_from_odo(). + (depending_on_value): Likewise. + (parser_display_field): Formatting. + (parser_display): Handle case ENV_NAME_e. + (parser_file_open): Avoid unnecessary store_location_stuff. + (parser_file_close): Likewise. + (parser_file_read): Likewise. + (parser_file_write): Likewise. + (parser_file_delete): Likewise. + (parser_file_rewrite): Likewise. + (parser_file_start): Likewise. + (parser_intrinsic_subst): Streamline get_depending_on_value_from_odo(). + (parser_intrinsic_call_1): Likewise. + (parser_lsearch_start): Likewise. + (parser_bsearch_start): Likewise. + (parser_sort): Likewise. + (store_location_stuff): Avoid unnecessary assignments. + (parser_pop_exception): Formatting. + * genmath.cc (parser_add): Avoid var_decl_default_compute_error assignment + when doing fast_add(). + (parser_subtract): Likewise. + * genutil.cc (REFER): Macro for analyzing code generation. + (get_integer_value): Use data_decl_node for integer value from FldLiteralN. + (get_data_offset): Streamline exception code processing. + (get_and_check_refstart_and_reflen): Likewise. + (get_depending_on_value_from_odo): Likewise. + (get_depending_on_value): Likewise. + (refer_is_clean): Formatting. + (refer_refmod_length): Streamline exception code processing. + (refer_fill_depends): Likewise. + (refer_offset): Likewise. + (refer_size_dest): Likewise. + (refer_size_source): Likewise. + * genutil.h (get_depending_on_value_from_odo): Likewise. + * lang-specs.h: Options definition. + * lang.opt: -M as in c.opt. + * lexio.h: Formatting. + * parse.y: Expand -dialect suggestions; SECTION SEGMENT messages. + * parse_ante.h (declarative_runtime_match): Dialect handling. + (labels_dump): Likewise. + (class current_tokens_t): Likewise. + (class prog_descr_t): Make program_index size_t to prevent padding bytes. + * scan.l: POP_FILE directive. + * scan_ante.h (class enter_leave_t): Better handle line number when + processing COPY statements. + * symbols.cc (symbol_elem_cmp): Eliminate SymFunction. + (symbols_dump): Likewise. + (symbol_label_section_exists): Likewise. + * symbols.h (NAME_MAX): Eliminate. (Was part of SymFunction). + (dialect_is): Improve dialect handling. + (dialect_gcc): Likewise. + (dialect_ibm): Likewise. + (dialect_gnu): Likewise. + (enum symbol_type_t): Eliminate SymFunction. + * util.cc (symbol_type_str): Likewise. + (class unique_stack): Option -M handling. + (cobol_set_pp_option): Likewise. + (parse_file): Likewise. + * util.h (cobol_set_pp_option): Likewise. + 2025-05-10 Robert Dubner <rdubner@symas.com> PR cobol/119337 diff --git a/gcc/cobol/Make-lang.in b/gcc/cobol/Make-lang.in index a474123..0e2a773 100644 --- a/gcc/cobol/Make-lang.in +++ b/gcc/cobol/Make-lang.in @@ -34,6 +34,9 @@ # - the compiler proper (eg: cc1plus) # - define the names for selecting the language in LANGUAGES. +# Use strict warnings for this front end. +cobol-warn = $(STRICT_WARN) + GCOBOL_INSTALL_NAME := $(shell echo gcobol|sed '$(program_transform_name)') GCOBOLIO_INSTALL_NAME := $(shell echo gcobol-io|sed '$(program_transform_name)') GCOBOL_TARGET_INSTALL_NAME := $(target_noncanonical)-$(shell echo gcobol|sed '$(program_transform_name)') @@ -159,8 +162,7 @@ FLEX_WARNING = warning, dangerous trailing context cobol/scan.cc: cobol/scan.l $(FLEX) -o$@ $(LFLAGS) $< 2>$@~ || { cat $@~ >&1; exit 1; } awk '! /$(FLEX_WARNING)/ {print > "/dev/stderr"; nerr++} \ - END {print "$(FLEX):", NR, "messages" > "/dev/stderr"; \ - exit nerr}' $@~ + END {print "$(FLEX):", NR, "messages" > "/dev/stderr"}' $@~ @rm $@~ @@ -285,7 +287,7 @@ cobol.install-common: installdirs rm -f $(DESTDIR)$(bindir)/$(GCOBOL_TARGET_INSTALL_NAME)$(exeext); \ rm -f $(DESTDIR)$(bindir)/$(GCOBC_TARGET_INSTALL_NAME)$(exeext); \ ( cd $(DESTDIR)$(bindir) && \ - $(LN) $(GCOBOL_INSTALL_NAME)$(exeext) $(GCOBOL_TARGET_INSTALL_NAME)$(exeext) ); \ + $(LN) $(GCOBOL_INSTALL_NAME)$(exeext) $(GCOBOL_TARGET_INSTALL_NAME)$(exeext) && \ $(LN) $(GCOBC_INSTALL_NAME)$(exeext) $(GCOBC_TARGET_INSTALL_NAME)$(exeext) ); \ fi; \ fi @@ -351,10 +353,16 @@ cobol.srcman: cobol.mostlyclean: -cobol.clean: +gcobol.clean: +# This is intended for non-general use. It is a last-ditch effort to flush +# out all oject files and executable code for gcobol and libgcobol, causing +# a complete rebuild of all executable code. rm -fr gcobol cobol1 cobol/* \ ../*/libgcobol/* +cobol.clean: + rm -fr gcobol cobol1 cobol/* + cobol.distclean: cobol.maintainer-clean: @@ -376,3 +384,4 @@ cobol.stagefeedback: stagefeedback-start selftest-cobol: lang_checks += check-cobol + diff --git a/gcc/cobol/TODO b/gcc/cobol/TODO new file mode 100644 index 0000000..02ee0e2 --- /dev/null +++ b/gcc/cobol/TODO @@ -0,0 +1,33 @@ +Below is listed work to be done, hopefully all of it in 2025 for +GCC 16. They are vaguely in priority order, in that addressing more +technical issues may illuminate ways to attack more amorphous ones. + +Portability: + - host/target, for cross-compilation + - OS portability, BSD, macOS, Solaris + - 64-bit portability, LE + - 64-bit portability, BE + - 2025 goal: Compile & run on primary & secondary GCC 15 platforms + https://www.gnu.org/software/gcc/gcc-15/criteria.html + +Correctness: + - LTO ODR, PR 119215 + - cppcheck + - valgrind + - -static produces dynamic + +Efficiency: + - Code size for MOVE 'a' TO FOO(1,1) + - EC checking + +COBOL Features: + - XML, JSON + - MF system functions + - National characters (and Unicode, for IBM) + - GLOBAL and PERFORM declaratives + - dialect feature names (to enable and enumerate) + +GCC features: + - make check-nist + - -Werror, -Wno-<foo> + - -fEC-ALL, -fno-EC-I-O diff --git a/gcc/cobol/cbldiag.h b/gcc/cobol/cbldiag.h index 3cb54e7..dd16190 100644 --- a/gcc/cobol/cbldiag.h +++ b/gcc/cobol/cbldiag.h @@ -33,7 +33,7 @@ #else #define _CBLDIAG_H -#if 0 +#if GCOBOL_GETENV #define gcobol_getenv(x) getenv(x) #else #define gcobol_getenv(x) ((char *)nullptr) @@ -45,8 +45,8 @@ const char * cobol_filename(); * These are user-facing messages. They go through the gcc * diagnostic framework and use text that can be localized. */ -void yyerror( const char fmt[], ... ); -bool yywarn( const char fmt[], ... ); +void yyerror( const char fmt[], ... ) ATTRIBUTE_GCOBOL_DIAG(1, 2); +bool yywarn( const char fmt[], ... ) ATTRIBUTE_GCOBOL_DIAG(1, 2); /* Location type. Borrowed from parse.h as generated by Bison. */ #if ! defined YYLTYPE && ! defined YYLTYPE_IS_DECLARED @@ -78,39 +78,58 @@ struct YDFLTYPE #endif +// Diagnostic format specifiers are documented in gcc/pretty-print.cc // an error at a location, called from the parser for semantic errors -void error_msg( const YYLTYPE& loc, const char gmsgid[], ... ); +void error_msg( const YYLTYPE& loc, const char gmsgid[], ... ) + ATTRIBUTE_GCOBOL_DIAG(2, 3); + +bool +warn_msg( const YYLTYPE& loc, const char gmsgid[], ... ) + ATTRIBUTE_GCOBOL_DIAG(2, 3); + +// an error that uses token_location, not yylloc +void error_msg_direct( const char gmsgid[], ... ) + ATTRIBUTE_GCOBOL_DIAG(1, 2); void dialect_error( const YYLTYPE& loc, const char term[], const char dialect[] ); // for CDF and other warnings that refer back to an earlier line // (not in diagnostic framework yet) -void yyerrorvl( int line, const char *filename, const char fmt[], ... ); +void yyerrorvl( int line, const char *filename, const char fmt[], ... ) + ATTRIBUTE_PRINTF_3; -void cbl_unimplementedw(const char *gmsgid, ...); // warning -void cbl_unimplemented(const char *gmsgid, ...); // error -void cbl_unimplemented_at( const YYLTYPE& loc, const char *gmsgid, ... ); +void cbl_unimplementedw(const char *gmsgid, ...) ATTRIBUTE_GCOBOL_DIAG(1, 2); // warning +void cbl_unimplemented(const char *gmsgid, ...) ATTRIBUTE_GCOBOL_DIAG(1, 2); // error +void cbl_unimplemented_at( const YYLTYPE& loc, const char *gmsgid, ... ) + ATTRIBUTE_GCOBOL_DIAG(2, 3); /* - * dbgmsg produce messages not intended for the user. They cannot - * be localized and fwrite directly to standard out. dbgmsg is activated by - * -fflex-debug or -fyacc-debug. + * dbgmsg produce messages not intended for the user. They cannot be localized + * and fwrite directly to standard error. dbgmsg is activated by -fflex-debug + * or -fyacc-debug. */ void dbgmsg( const char fmt[], ... ) ATTRIBUTE_PRINTF_1; void gcc_location_set( const YYLTYPE& loc ); +void gcc_location_dump(); + // tree.h defines yy_flex_debug as a macro because options.h #if ! defined(yy_flex_debug) template <typename LOC> static void location_dump( const char func[], int line, const char tag[], const LOC& loc) { - extern int yy_flex_debug; - if( yy_flex_debug && gcobol_getenv("update_location") ) - fprintf(stderr, "%s:%d: %s location (%d,%d) to (%d,%d)\n", - func, line, tag, - loc.first_line, loc.first_column, loc.last_line, loc.last_column); + extern int yy_flex_debug; // cppcheck-suppress shadowVariable + if( yy_flex_debug ) { + const char *detail = gcobol_getenv("update_location"); // cppcheck-suppress knownConditionTrueFalse + if( detail ) { + fprintf(stderr, "%s:%d: %s location (%d,%d) to (%d,%d)\n", + func, line, tag, + loc.first_line, loc.first_column, loc.last_line, loc.last_column); + if( *detail == '2' ) gcc_location_dump(); + } + } } #endif // defined(yy_flex_debug) diff --git a/gcc/cobol/cdf-copy.cc b/gcc/cobol/cdf-copy.cc index 059596c..11be9b8 100644 --- a/gcc/cobol/cdf-copy.cc +++ b/gcc/cobol/cdf-copy.cc @@ -35,23 +35,12 @@ // We regret any confusion engendered. #include "config.h" -#include <glob.h> #include "cobol-system.h" #include "cbldiag.h" #include "util.h" #include "copybook.h" -// GLOB_BRACE and GLOB_TILDE are BSD extensions. Provide fallback definitions -// if necessary. -#ifndef GLOB_BRACE -#define GLOB_BRACE 0 -#endif - -#ifndef GLOB_TILDE -#define GLOB_TILDE 0 -#endif - #define COUNT_OF(X) (sizeof(X) / sizeof(X[0])) /* @@ -86,7 +75,6 @@ * space. This function only applies them. */ -extern int yydebug; const char * cobol_filename(); bool is_fixed_format(); bool is_reference_format(); @@ -136,13 +124,13 @@ verify_bounds( size_t pos, size_t size, const char input[] ) { */ const char * esc( size_t len, const char input[] ) { - static char spaces[] = "([,;]?[[:space:]])+"; - static char spaceD[] = "(\n {6}D" "|" "[,;]?[[:space:]])+"; + static const char space[] = "([,;]?[[:space:]])+"; + static const char spaceD[] = "(\n {6}D" "|" "[,;]?[[:space:]])+"; static char buffer[64 * 1024]; char *p = buffer; const char *eoinput = input + len; - const char *spacex = is_reference_format()? spaceD : spaces; + const char *spacex = is_reference_format()? spaceD : space; for( const char *s=input; *s && s < eoinput; s++ ) { *p = '\0'; @@ -190,12 +178,6 @@ esc( size_t len, const char input[] ) { return buffer; // caller must strdup static buffer } -static int -glob_error(const char *epath, int eerrno) { - dbgmsg("%s: COPY file search: '%s': %s", __func__, epath, xstrerror(eerrno)); - return 0; -} - void copybook_directory_add( const char gcob_copybook[] ) { if( !gcob_copybook ) return; @@ -242,27 +224,15 @@ copybook_extension_add( const char ext[] ) { copybook.extensions_add( ext, alt ); } -extern int yydebug; -const char * copybook_elem_t::extensions; +std::list<const char *> copybook_elem_t::suffixes { + "", ".cpy", ".CPY", ".cbl", ".CBL", ".cob", ".COB" +}; void copybook_t::extensions_add( const char ext[], const char alt[] ) { - char *output; - if( alt ) { - output = xasprintf("%s,%s", ext, alt); - } else { - output = xstrdup(ext); - } - gcc_assert(output); - if( book.extensions ) { - char *s = xasprintf("%s,%s", output, book.extensions); - free(const_cast<char*>(book.extensions)); - free(output); - book.extensions = s; - } else { - book.extensions = output; - } + book.suffixes.push_back(ext); + if( alt ) book.suffixes.push_back(alt); } static inline ino_t @@ -276,9 +246,7 @@ inode_of( int fd ) { int copybook_elem_t::open_file( const char directory[], bool literally ) { - int erc; - char *pattern, *copier = xstrdup(cobol_filename()); - char *dname = NULL; + char *dname = NULL, *copier = xstrdup(cobol_filename()); if ( directory ) { dname = xstrdup(directory); @@ -311,7 +279,7 @@ copybook_elem_t::open_file( const char directory[], bool literally ) { dbgmsg("copybook_elem_t::open_file: trying %s", path); if( (this->fd = open(path, O_RDONLY)) == -1 ) { - dbgmsg("could not open %s: %m", path); + dbgmsg("could not open %s: %s", path, xstrerror(errno)); return fd; } this->source.name = path; @@ -324,52 +292,27 @@ copybook_elem_t::open_file( const char directory[], bool literally ) { } gcc_assert( ! literally ); - if( extensions ) { - pattern = xasprintf("%s{,.cpy,.CPY,.cbl,.CBL,.cob,.COB,%s}", - path, this->extensions); - } else { - pattern = xasprintf("%s{,.cpy,.CPY,.cbl,.CBL,.cob,.COB}", path); - } - free(copier); - static int flags = GLOB_MARK | GLOB_BRACE | GLOB_TILDE; - glob_t globber; - - if( (erc = glob(pattern, flags, glob_error, &globber)) != 0 ) { - switch(erc) { - case GLOB_NOSPACE: - yywarn("COPY file search: out of memory"); - break; - case GLOB_ABORTED: - yywarn("COPY file search: read error"); - break; - case GLOB_NOMATCH: - dbgmsg("COPY '%s': no files match %s", this->source.name, pattern); - default: - break; // caller says no file found - } - return -1; - } - - free(pattern); + for( auto suffix : suffixes ) { + std::string pattern(path); + pattern += suffix; + dbgmsg("%s: trying %s", __func__, pattern.c_str()); - for( size_t i=0; i < globber.gl_pathc; i++ ) { - auto filename = globber.gl_pathv[i]; + auto filename = pattern.c_str(); if( (this->fd = open(filename, O_RDONLY)) != -1 ) { dbgmsg("found copybook file %s", filename); this->source.name = xstrdup(filename); if( ! cobol_filename(this->source.name, inode_of(fd)) ) { - error_msg(source.loc, "recursive copybook: '%s' includes itself", this->source); + error_msg(source.loc, "recursive copybook: '%s' includes itself", + this->source.name); (void)! close(fd); fd = -1; } - globfree(&globber); + dbgmsg("%s: opened %s as fd %d", __func__, source.name, fd); return fd; } } - yywarn("could not open copy source for '%s'", source); - globfree(&globber); return -1; } diff --git a/gcc/cobol/cdf.y b/gcc/cobol/cdf.y index 7680f48..53fea5d 100644 --- a/gcc/cobol/cdf.y +++ b/gcc/cobol/cdf.y @@ -95,7 +95,7 @@ void input_file_status_notify(); } \ location_dump("cdf.c", __LINE__, "current", (Current)); \ input_file_status_notify(); \ - gcc_location_set( location_set(Current) ); \ + location_set(Current); \ } while (0) %} @@ -105,14 +105,14 @@ void input_file_status_notify(); using std::map; - static map<std::string, cdfval_t> dictionary; - #pragma GCC diagnostic push #pragma GCC diagnostic ignored "-Wunused-function" static bool cdfval_add( const char name[], const cdfval_t& value, bool override = false ) { + cdf_values_t& dictionary( cdf_dictionary() ); + if( scanner_parsing() ) { if( ! override ) { if( dictionary.find(name) != dictionary.end() ) return false; @@ -123,6 +123,8 @@ void input_file_status_notify(); } static void cdfval_off( const char name[] ) { + cdf_values_t& dictionary( cdf_dictionary() ); + if( scanner_parsing() ) { auto p = dictionary.find(name); if( p == dictionary.end() ) { @@ -159,6 +161,8 @@ exception_turn_t exception_turn; bool apply_cdf_turn( const exception_turn_t& turn ) { + cbl_enabled_exceptions_t& enabled_exceptions( cdf_enabled_exceptions() ); + for( auto elem : turn.exception_files() ) { std::set<size_t> files(elem.second.begin(), elem.second.end()); enabled_exceptions.turn_on_off(turn.enabled, @@ -185,6 +189,7 @@ apply_cdf_turn( const exception_turn_t& turn ) { %printer { fprintf(yyo, "%s '%s'", keyword_str($$.token), $$.string? $$.string : "<nil>" ); } <cdfarg> +/* cppcheck-suppress invalidPrintfArgType_sint */ %printer { fprintf(yyo, HOST_SIZE_T_PRINT_DEC " '%s'", (fmt_size_t)$$.number, $$.string? $$.string : "" ); } <cdfval> @@ -203,15 +208,17 @@ apply_cdf_turn( const exception_turn_t& turn ) { %type <file> filename %type <files> filenames -%token BY 478 +%type <number> cdf_stackable + +%token BY 486 %token COPY 362 %token CDF_DISPLAY 384 ">>DISPLAY" -%token IN 597 +%token IN 605 %token NAME 286 %token NUMSTR 305 "numeric literal" -%token OF 678 -%token PSEUDOTEXT 713 -%token REPLACING 735 +%token OF 686 +%token PSEUDOTEXT 721 +%token REPLACING 743 %token LITERAL 298 %token SUPPRESS 376 @@ -226,25 +233,32 @@ apply_cdf_turn( const exception_turn_t& turn ) { %token CDF_WHEN 389 ">>WHEN" %token CDF_END_EVALUATE 390 ">>END-EVALUATE" -%token AS 460 CONSTANT 361 DEFINED 363 +%token ALL 450 +%token CALL_CONVENTION 391 ">>CALL-CONVENTION" +%token COBOL_WORDS 380 ">>COBOL-WORDS" +%token CDF_PUSH 394 ">>PUSH" +%token CDF_POP 395 ">>POP" +%token SOURCE_FORMAT 396 ">>SOURCE FORMAT" + +%token AS 468 CONSTANT 361 DEFINED 363 %type <boolean> DEFINED -%token OTHER 690 PARAMETER_kw 368 "PARAMETER" -%token OFF 679 OVERRIDE 369 -%token THRU 931 -%token TRUE_kw 805 "True" +%token OTHER 698 PARAMETER_kw 368 "PARAMETER" +%token OFF 687 OVERRIDE 369 +%token THRU 939 +%token TRUE_kw 813 "True" -%token CALL_COBOL 391 "CALL" -%token CALL_VERBATIM 392 "CALL (as C)" +%token CALL_COBOL 392 "CALL" +%token CALL_VERBATIM 393 "CALL (as C)" -%token TURN 807 CHECKING 488 LOCATION 641 ON 681 WITH 833 +%token TURN 815 CHECKING 496 LOCATION 649 ON 689 WITH 841 -%left OR 932 -%left AND 933 -%right NOT 934 -%left '<' '>' '=' NE 935 LE 936 GE 937 +%left OR 940 +%left AND 941 +%right NOT 942 +%left '<' '>' '=' NE 943 LE 944 GE 945 %left '-' '+' %left '*' '/' -%right NEG 939 +%right NEG 947 %define api.prefix {ydf} %define api.token.prefix{YDF_} @@ -262,8 +276,8 @@ top: partials { YYACCEPT; } YYACCEPT; } | copy error { - error_msg(@error, "COPY directive must end in a '.'"); - YYACCEPT; + error_msg(@error, "COPY directive must end in a %<.%>"); + YYABORT; } | completes { YYACCEPT; } ; @@ -276,6 +290,8 @@ complete: cdf_define | cdf_display | cdf_turn | cdf_call_convention + | cdf_push + | cdf_pop ; /* @@ -327,6 +343,7 @@ cdf_define: CDF_DEFINE cdf_constant NAME as cdf_expr[value] override } if( !cdfval_add( $NAME, cdfval_t($value), $override) ) { error_msg(@NAME, "name already in dictionary: %s", $NAME); + cdf_values_t& dictionary( cdf_dictionary() ); const cdfval_t& entry = dictionary[$NAME]; if( entry.filename ) { error_msg(@NAME, "%s previously defined in %s:%d", @@ -356,7 +373,7 @@ cdf_define: CDF_DEFINE cdf_constant NAME as cdf_expr[value] override * available regardless. */ { - if( 0 == dictionary.count($NAME) ) { + if( 0 == cdf_dictionary().count($NAME) ) { yywarn("CDF: '%s' is defined AS PARAMETER " "but was not defined", $NAME); } @@ -364,13 +381,15 @@ cdf_define: CDF_DEFINE cdf_constant NAME as cdf_expr[value] override | CDF_DEFINE FEATURE as ON { auto feature = cbl_gcobol_feature_t($2); if( ! cobol_gcobol_feature_set(feature, true) ) { - error_msg(@FEATURE, ">>DEFINE %EBCDIC-MODE is invalid within program body"); + error_msg(@FEATURE, + "%<>>DEFINE %%EBCDIC-MODE%> is invalid within program body"); } } | CDF_DEFINE FEATURE as OFF { auto feature = cbl_gcobol_feature_t($2); if( ! cobol_gcobol_feature_set(feature, false) ) { - error_msg(@FEATURE, ">>DEFINE %EBCDIC-MODE is invalid within program body"); + error_msg(@FEATURE, + "%<>>DEFINE %%EBCDIC-MODE%> is invalid within program body"); } } ; @@ -397,6 +416,35 @@ cdf_call_convention: } ; +cdf_push: CDF_PUSH cdf_stackable { + switch( $cdf_stackable ) { + case YDF_ALL: cdf_push(); break; + case YDF_CALL_CONVENTION: cdf_push_call_convention(); break; + case YDF_CDF_DEFINE: cdf_push_dictionary(); break; + case YDF_COBOL_WORDS: cdf_push_current_tokens(); break; + case YDF_SOURCE_FORMAT: cdf_push_source_format(); break; + default: gcc_unreachable(); + } + } + ; +cdf_pop: CDF_POP cdf_stackable { + switch( $cdf_stackable ) { + case YDF_ALL: cdf_pop(); break; + case YDF_CALL_CONVENTION: cdf_pop_call_convention(); break; + case YDF_CDF_DEFINE: cdf_pop_dictionary(); break; + case YDF_COBOL_WORDS: cdf_pop_current_tokens(); break; + case YDF_SOURCE_FORMAT: cdf_pop_source_format(); break; + default: gcc_unreachable(); + } + } + ; + +cdf_stackable: ALL { $$ = YDF_ALL; } + | CALL_CONVENTION { $$ = YDF_CALL_CONVENTION; } + | COBOL_WORDS { $$ = YDF_COBOL_WORDS; } + | CDF_DEFINE { $$ = YDF_CDF_DEFINE; } + | SOURCE_FORMAT { $$ = YDF_SOURCE_FORMAT; } + ; except_names: except_name | except_names except_name @@ -429,7 +477,7 @@ filenames: filename { auto inserted = $$->insert(symbol_index(symbol_elem_of($2))); if( ! inserted.second ) { error_msg(@2, "%s: No file-name shall be specified more than " - " once for one exception condition", $filename->name); + "once for one exception condition", $filename->name); } } ; @@ -468,6 +516,7 @@ cdf_eval_obj: cdf_cond_expr cdf_cond_expr: BOOL | NAME DEFINED { + cdf_values_t& dictionary( cdf_dictionary() ); auto p = dictionary.find($1); bool found = p != dictionary.end(); if( !$DEFINED ) found = ! found; @@ -516,7 +565,7 @@ cdf_relexpr: cdf_relexpr '<' cdf_expr { $$ = $1(@1) < $3(@3); } const char *msg = $1.string? "incommensurate comparison is FALSE: '%s' = %ld" : "incommensurate comparison is FALSE: %ld = '%s'" ; - error_msg(@1, msg); + error_msg(@1, "%s", msg); } } | cdf_relexpr NE cdf_expr @@ -530,7 +579,7 @@ cdf_relexpr: cdf_relexpr '<' cdf_expr { $$ = $1(@1) < $3(@3); } const char *msg = $1.string? "incommensurate comparison is FALSE: '%s' = %ld" : "incommensurate comparison is FALSE: %ld = '%s'" ; - error_msg(@1, msg); + error_msg(@1, "%s", msg); } } | cdf_relexpr GE cdf_expr { $$ = $1(@1) >= $3(@3); } @@ -549,6 +598,7 @@ cdf_expr: cdf_expr '+' cdf_expr { $$ = $1(@1) + $3(@3); } ; cdf_factor: NAME { + cdf_values_t& dictionary( cdf_dictionary() ); auto that = dictionary.find($1); if( that != dictionary.end() ) { $$ = that->second; @@ -566,7 +616,7 @@ cdf_factor: NAME { | NUMSTR { auto value = integer_literal($NUMSTR); if( !value.second ) { - error_msg(@1, "CDF error: parsed %s as %ld", + error_msg(@1, "CDF error: parsed %qs as %lld", $NUMSTR, value.first); YYERROR; } @@ -584,7 +634,7 @@ copybook_name: COPY name_one[src] if( -1 == copybook.open(@src, $src.string) ) { error_msg(@src, "could not open copybook file " "for '%s'", $src.string); - YYERROR; + YYABORT; } } | COPY name_one[src] IN name_one[lib] @@ -592,8 +642,8 @@ copybook_name: COPY name_one[src] copybook.library(@lib, $lib.string); if( -1 == copybook.open(@src, $src.string) ) { error_msg(@src, "could not open copybook file " - "for '%s' in '%'s'", $src.string, $lib.string); - YYERROR; + "for %<%s%> in %<%s%>", $src.string, $lib.string); + YYABORT; } } ; @@ -648,6 +698,7 @@ name_any: namelit name_one: NAME { + cdf_values_t& dictionary( cdf_dictionary() ); cdf_arg_t arg = { YDF_NAME, $1 }; auto p = dictionary.find($1); @@ -662,6 +713,7 @@ name_one: NAME namelit: name { + cdf_values_t& dictionary( cdf_dictionary() ); cdf_arg_t arg = { YDF_NAME, $1 }; auto p = dictionary.find($1); @@ -742,6 +794,7 @@ location_set( const YYLTYPE& loc ) { bool // used by cobol1.cc defined_cmd( const char arg[] ) { + cdf_values_t& dictionary( cdf_dictionary() ); cdfval_t value(1); char *name = xstrdup(arg); @@ -864,7 +917,8 @@ static int ydflex(void) { } bool -cdf_value( const char name[], cdfval_t value ) { +cdf_value( const char name[], const cdfval_t& value ) { + cdf_values_t& dictionary( cdf_dictionary() ); auto p = dictionary.find(name); if( p != dictionary.end() ) return false; @@ -875,6 +929,7 @@ cdf_value( const char name[], cdfval_t value ) { const cdfval_t * cdf_value( const char name[] ) { + cdf_values_t& dictionary( cdf_dictionary() ); auto p = dictionary.find(name); if( p == dictionary.end() ) return NULL; @@ -894,5 +949,6 @@ verify_integer( const YDFLTYPE& loc, const cdfval_base_t& val ) { const cdfval_base_t& cdfval_base_t::operator()( const YDFLTYPE& loc ) { static cdfval_t zero(0); + // cppcheck-suppress returnTempReference return verify_integer(loc, *this) ? *this : zero; } diff --git a/gcc/cobol/cdfval.h b/gcc/cobol/cdfval.h index 634b5a2..cc474a2 100644 --- a/gcc/cobol/cdfval.h +++ b/gcc/cobol/cdfval.h @@ -32,12 +32,20 @@ #ifndef _CDF_VAL_H_ #define _CDF_VAL_H_ -#include <assert.h> -#include <stdint.h> -#include <stdlib.h> +#include <cassert> +#include <cstdint> +#include <cstdlib> bool scanner_parsing(); +/* cdfval_base_t has no constructor because otherwise: + * cobol/cdf.h:172:7: note: ‘YDFSTYPE::YDFSTYPE()’ is implicitly deleted + * because the default definition would be ill-formed: + * 172 | union YDFSTYPE + * + * We use the derived type cdfval_t, which can be properly constructed and + * operated on, but tell Bison only about its POD base class. + */ struct YDFLTYPE; struct cdfval_base_t { bool off; @@ -65,28 +73,28 @@ struct cdfval_t : public cdfval_base_t { cdfval_base_t::string = NULL; cdfval_base_t::number = 0; } - cdfval_t( const char value[] ) + cdfval_t( const char value[] ) // cppcheck-suppress noExplicitConstructor : lineno(yylineno), filename(cobol_filename()) { cdfval_base_t::off = false; cdfval_base_t::string = value; cdfval_base_t::number = 0; } - cdfval_t( long long value ) + cdfval_t( long long value ) // cppcheck-suppress noExplicitConstructor : lineno(yylineno), filename(cobol_filename()) { cdfval_base_t::off = false; cdfval_base_t::string = NULL; cdfval_base_t::number = value; } - cdfval_t( long value ) + cdfval_t( long value ) // cppcheck-suppress noExplicitConstructor : lineno(yylineno), filename(cobol_filename()) { cdfval_base_t::off = false; cdfval_base_t::string = NULL; cdfval_base_t::number = value; } - cdfval_t( int value ) + cdfval_t( int value ) // cppcheck-suppress noExplicitConstructor : lineno(yylineno), filename(cobol_filename()) { cdfval_base_t::off = false; @@ -101,7 +109,7 @@ struct cdfval_t : public cdfval_base_t { HOST_WIDE_INT value = real_to_integer(&r); cdfval_base_t::number = value; } - cdfval_t( const cdfval_base_t& value ) + cdfval_t( const cdfval_base_t& value ) // cppcheck-suppress noExplicitConstructor : lineno(yylineno), filename(cobol_filename()) { cdfval_base_t *self(this); @@ -116,6 +124,10 @@ const cdfval_t * cdf_value( const char name[] ); bool -cdf_value( const char name[], cdfval_t value ); +cdf_value( const char name[], const cdfval_t& value ); + +typedef std::map<std::string, cdfval_t> cdf_values_t; + +cdf_values_t& cdf_dictionary(); #endif diff --git a/gcc/cobol/cobol-system.h b/gcc/cobol/cobol-system.h index ff95835..828f4f5 100644 --- a/gcc/cobol/cobol-system.h +++ b/gcc/cobol/cobol-system.h @@ -60,4 +60,10 @@ // The following "local" #include is part of the GCC core code #include "system.h" +#if (CHECKING_P && GCC_VERSION >= 4001) || GCC_VERSION == BUILDING_GCC_VERSION +#define ATTRIBUTE_GCOBOL_DIAG(m, n) __attribute__ ((__format__ (__gcc_tdiag__, m, n))) ATTRIBUTE_NONNULL(m) +#else +#define ATTRIBUTE_GCOBOL_DIAG(m, n) ATTRIBUTE_NONNULL(m) +#endif + #endif diff --git a/gcc/cobol/cobol1.cc b/gcc/cobol/cobol1.cc index 3bd21c7..3146da5 100644 --- a/gcc/cobol/cobol1.cc +++ b/gcc/cobol/cobol1.cc @@ -20,15 +20,15 @@ along with GCC; see the file COPYING3. If not see #include "cobol-system.h" -#include "coretypes.h" -#include "tree.h" -#include "diagnostic.h" -#include "opts.h" -#include "debug.h" -#include "langhooks.h" -#include "langhooks-def.h" -#include "target.h" -#include "stringpool.h" +#include <coretypes.h> +#include <tree.h> +#include <diagnostic.h> +#include <opts.h> +#include <debug.h> +#include <langhooks.h> +#include <langhooks-def.h> +#include <target.h> +#include <stringpool.h> #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" #include "util.h" @@ -39,7 +39,6 @@ along with GCC; see the file COPYING3. If not see #include "genapi.h" #include "../../libgcobol/exceptl.h" #include "exceptg.h" -#include "util.h" #include "gengen.h" // This has some GTY(()) markers #include "structs.h" // This has some GTY(()) markers @@ -357,6 +356,10 @@ cobol_langhook_handle_option (size_t scode, copybook_extension_add(cobol_copyext); return true; + case OPT_M: + cobol_set_pp_option('M'); + return true; + case OPT_fstatic_call: use_static_call( arg? true : false ); return true; @@ -365,16 +368,18 @@ cobol_langhook_handle_option (size_t scode, wsclear(cobol_default_byte); return true; - case OPT_fflex_debug: + case OPT_fflex_debug: // cppcheck-suppress syntaxError // The need for this is a mystery yy_flex_debug = 1; cobol_set_debugging( true, yy_debug == 1, cobol_trace_debug == 1 ); return true; + case OPT_fyacc_debug: yy_debug = 1; cobol_set_debugging(yy_flex_debug == 1, true, cobol_trace_debug == 1 ); return true; + case OPT_ftrace_debug: cobol_set_debugging( yy_flex_debug == 1, yy_debug == 1, true ); return true; @@ -403,11 +408,13 @@ cobol_langhook_handle_option (size_t scode, case OPT_fsyntax_only: mode_syntax_only(identification_div_e); break; + case OPT_preprocess: if( ! preprocess_filter_add(arg) ) { cbl_errx( "could not execute preprocessor %s", arg); } return true; + case OPT_include: if( ! include_file_add(arg) ) { cbl_errx( "could not include %s", arg); @@ -568,7 +575,7 @@ cobol_name_mangler(const char *cobol_name_) } // Allocate enough space for a prepended underscore and a final '\0' - char *cobol_name = (char *)xmalloc(strlen(cobol_name_)+2); + char *cobol_name = static_cast<char *>(xmalloc(strlen(cobol_name_)+2)); size_t n = 0; if( cobol_name_[0] >= '0' && cobol_name_[0] <= '9' ) { diff --git a/gcc/cobol/copybook.h b/gcc/cobol/copybook.h index e509bf3..ff8c6d0 100644 --- a/gcc/cobol/copybook.h +++ b/gcc/cobol/copybook.h @@ -62,10 +62,10 @@ class copybook_elem_t { struct copybook_loc_t { YYLTYPE loc; const char *name; - copybook_loc_t() : name(NULL) {} + copybook_loc_t() : loc(), name(NULL) {} } source, library; bool suppress; - static const char *extensions; + static std::list<const char *> suffixes; public: struct { bool source, library; } literally; int fd; @@ -74,12 +74,11 @@ class copybook_elem_t { copybook_elem_t() : suppress(false) + , literally() , fd(-1) , nsubexpr(0) , regex_text(NULL) - { - literally = {}; - } + {} void clear() { suppress = false; @@ -91,7 +90,6 @@ class copybook_elem_t { } int open_file( const char dir[], bool literally = false ); - void extensions_add( const char ext[], const char alt[] ); static inline bool is_quote( const char ch ) { return ch == '\'' || ch == '"'; @@ -102,7 +100,7 @@ class copybook_elem_t { } static char * dequote( const char orig[] ) { gcc_assert(quoted(orig)); - auto name = (char*)xcalloc(1, strlen(orig)); + auto name = static_cast<char*>(xcalloc(1, strlen(orig))); gcc_assert(name); char *tgt = name; @@ -131,7 +129,7 @@ private: class uppername_t { std::string upper; public: - uppername_t( const std::string input ) : upper(input) { + explicit uppername_t( const std::string& input ) : upper(input) { std::transform(input.begin(), input.end(), upper.begin(), []( char ch ) { return TOUPPER(ch); } ); } @@ -185,12 +183,10 @@ class copybook_t { this->source(loc, name); for( auto dir : directories ) { - if( true ) { - dbgmsg("copybook_t::open '%s' OF '%s' %s", - book.source.name, - dir? dir: ".", - book.literally.source? ", literally" : "" ); - } + dbgmsg("copybook_t::open '%s' OF '%s' %s", + book.source.name, + dir? dir: ".", + book.literally.source? ", literally" : "" ); if( (fd = book.open_file(dir, book.literally.source)) != -1 ) break; } return fd; diff --git a/gcc/cobol/dts.h b/gcc/cobol/dts.h index dfd7c4c..c900c45 100644 --- a/gcc/cobol/dts.h +++ b/gcc/cobol/dts.h @@ -35,13 +35,13 @@ namespace dts { { static regmatch_t empty; empty.rm_so = empty.rm_eo = -1; - regmatch_t& self(*this); + regmatch_t& self(*this); // cppcheck-suppress constVariableReference self = empty; } csub_match( const char input[], const regmatch_t& m ) : input(input) { - regmatch_t& self(*this); + regmatch_t& self(*this); // cppcheck-suppress constVariableReference self = m; matched = rm_so != -1; first = rm_so == -1? NULL : input + rm_so; @@ -68,7 +68,6 @@ namespace dts { #if __cpp_exceptions throw std::logic_error(msg); #else - pattern = NULL; cbl_errx("%s", msg); #endif } @@ -78,7 +77,7 @@ namespace dts { size_t size() const { return nsubexpr; } bool ready() const { return pattern != NULL; } private: - regex( const regex& ) {} + regex( const regex& ) = default; }; inline bool regex_search( const char input[], const char *eoinput, @@ -87,24 +86,30 @@ namespace dts { #if __cpp_exceptions static const char msg[] = "input not NUL-terminated"; throw std::domain_error( msg ); -#else - eoinput = strchr(input, '\0'); #endif } - if( eoinput == NULL ) eoinput = strchr(input, '\0'); auto ncm = re.size(); cm.resize(ncm); std::vector <regmatch_t> cms(ncm); - int erc = regexec( &re, input, ncm, cms.data(), 0 ); if( erc != 0 ) return false; +#if __cpp_exceptions + // This is not correct at all, but current use depends on current behavior. + // The following line is excluded from the GCC build, which is compiled + // without __cpp_exceptions. parse_copy_directive (for one) depends on + // regex_search returning true even if the match is beyond eoinput. + if( eoinput < cm[0].second ) return false; + // Correct behavior would return match only between input and eoinput. + // Because regex(3) uses a NUL terminator, it may match text between + // eoinput and the NUL. +#endif std::transform( cms.begin(), cms.end(), cm.begin(), [input]( const regmatch_t& m ) { return csub_match( input, m ); } ); return true; } -}; +} diff --git a/gcc/cobol/except.cc b/gcc/cobol/except.cc index 2118233..df1c7df 100644 --- a/gcc/cobol/except.cc +++ b/gcc/cobol/except.cc @@ -51,7 +51,7 @@ static const ec_descr_t * ec_type_descr( ec_type_t type ) { auto p = std::find( __gg__exception_table, __gg__exception_table_end, type ); if( p == __gg__exception_table_end ) { - cbl_internal_error("no such exception: 0x%04x", type); + cbl_internal_error("no such exception: 0x%x", type); } return p; } @@ -77,15 +77,13 @@ ec_level( ec_type_t ec ) { void cbl_enabled_exception_t::dump( int i ) const { - cbl_message(2, "cbl_enabled_exception_t: %2d {%s, %s, %s, %zu}", - i, - location? "location" : " none", - ec_type_str(ec), - file ); + cbl_message(2, "cbl_enabled_exception_t: %2d {%s, %s, %zu}", + i, + location? "location" : " none", + ec_type_str(ec), + file ); } -cbl_enabled_exceptions_t enabled_exceptions; - void cbl_enabled_exceptions_t::dump() const { extern int yydebug; @@ -98,24 +96,26 @@ cbl_enabled_exceptions_t::dump() const { return; } int i = 1; - for( auto& elem : *this ) { - dbgmsg("cbl_enabled_exceptions_t: %2d {%s, %s, %zu}", + for( auto& elem : *this ) { // cppcheck-suppress constVariableReference + dbgmsg("cbl_enabled_exceptions_t: %2d {%s, %s, %lu}", i++, elem.location? "with location" : " no location", ec_type_str(elem.ec), - elem.file ); + gb4(elem.file) ); } std::swap(debug, yydebug); } +// cppcheck-suppress-begin [useStlAlgorithm] because why? uint32_t cbl_enabled_exceptions_t::status() const { uint32_t status_word = 0; for( const auto& ena : *this ) { status_word |= (EC_ALL_E & ena.ec ); - } + } return status_word; } +// cppcheck-suppress-end useStlAlgorithm std::vector<uint64_t> cbl_enabled_exceptions_t::encode() const { @@ -133,13 +133,13 @@ void cbl_enabled_exceptions_t::turn_on_off( bool enabled, bool location, ec_type_t type, - std::set<size_t> files ) + const std::set<size_t>& files ) { // Update current enabled ECs tree on leaving this function. class update_parser_t { const cbl_enabled_exceptions_t& ecs; public: - update_parser_t(const cbl_enabled_exceptions_t& ecs) : ecs(ecs) {} + explicit update_parser_t(const cbl_enabled_exceptions_t& ecs) : ecs(ecs) {} ~update_parser_t() { tree ena = parser_compile_ecs(ecs.encode()); current_enabled_ecs(ena); @@ -244,16 +244,6 @@ cbl_enabled_exceptions_t::match( ec_type_t type, size_t file ) const { return output != end()? &*output : NULL; } -class choose_declarative { - size_t program; - public: - choose_declarative( size_t program ) : program(program) {} - - bool operator()( const cbl_declarative_t& dcl ) { - return dcl.global || program == symbol_at(dcl.section)->program; - } -}; - bool sort_supers_last( const cbl_declarative_t& a, const cbl_declarative_t& b ) { if( symbol_at(a.section)->program == symbol_at(b.section)->program ) { @@ -263,66 +253,6 @@ sort_supers_last( const cbl_declarative_t& a, const cbl_declarative_t& b ) { } cbl_field_t * new_temporary_decl(); - -/* - * For a program, create a "DECLARATIVES" entry in the symbol table, - * representing eligible declarative sections in priorty order: - * in-program first, followed by any global declaratives in parent - * programs. These decribe the USE criteria declared for each - * declarative section. - * - * The field's initial value is actually an array of - * cbl_declarartive_t, in which the first element is unused, except - * that array[0].section represents the number of elements, starting - * at array[1]. - * - * The returned value is the declarative's symbol index. It is passed - * to match_exception, which scans it for a declarative whose criteria - * match the raised exception. That function returns the - * cbl_declarative_t::section, which the program then uses to PERFORM - * that section. - */ -size_t -symbol_declaratives_add( size_t program, - const std::list<cbl_declarative_t>& dcls ) -{ - auto n = dcls.size(); - if( n == 0 ) return 0; - - auto blob = new cbl_declarative_t[ 1 + n ]; - - auto pend = std::copy_if( dcls.begin(), dcls.end(), blob + 1, - choose_declarative(program) ); - - std::sort( blob + 1, pend, sort_supers_last ); - - // Overload blob[0].section to be the count. - blob[0].section = (pend - blob) - 1; - - size_t len = reinterpret_cast<char*>(pend) - - reinterpret_cast<char*>(blob); - assert(len == (blob[0].section + 1) * sizeof(blob[0])); - - // Construct a "blob" in the symbol table. - static int blob_count = 1; - char achBlob[32]; - sprintf(achBlob, "_DECLARATIVE_BLOB%d_", blob_count++); - - cbl_field_data_t data = {}; - data.memsize = capacity_cast(len); - data.capacity = capacity_cast(len); - data.initial = reinterpret_cast<char*>(blob); - data.picture = reinterpret_cast<char*>(blob); - cbl_field_t field = { 0, FldBlob, FldInvalid, constant_e, - 0, 0, 0, cbl_occurs_t(), 0, "", - 0, {}, data, NULL }; - strcpy(field.name, achBlob); - - auto e = symbol_field_add(program, &field); - parser_symbol_add(cbl_field_of(e)); - return symbol_index(e); -} - /* * Generate the code to evaluate declaratives. This is the "secret * section" right after END DECLARATIVES. Its name is @@ -345,37 +275,42 @@ size_t current_file_index(); file_status_t current_file_handled_status(); void -declarative_runtime_match( cbl_field_t *declaratives, cbl_label_t *lave ) { +declarative_runtime_match( const std::list<cbl_declarative_t>& declaratives, + cbl_label_t *lave ) +{ if( getenv("GCOBOL_SHOW") ) { fprintf(stderr, "( %d ) %s: \n", cobol_location().first_line, __func__); } if( getenv("GCOBOL_TRACE") ) { - gg_printf(">>>>>>( %d )(%s) declaratives:%s lave:%s\n", + gg_printf(">>>>>>( %d )(%s) declaratives: lave:%s\n", build_int_cst_type(INT, cobol_location().first_line), gg_string_literal(__func__), - gg_string_literal(declaratives->name), gg_string_literal(lave->name), NULL_TREE); } static auto yes = new_temporary(FldConditional); - static auto psection = new_temporary(FldNumericBin5); + static auto isection = new_temporary(FldNumericBin5); + static auto index = new_temporary(FldNumericBin5); + /* + * Generate a sequence of COBOL IF statements to match the Declarative's + * symbol table index to its performable section. The entire sequence is + * guarded by a runtime IF that evaluates to TRUE only if the "current EC" is + * nonzero. This way, when _DECLARATIVES_EVAL is performed, it does nothing + * if no EC was raised. + */ IF( var_decl_exception_code, ne_op, integer_zero_node ) { - // Send blob, get declarative section index. - auto index = new_temporary(FldNumericBin5); + // Get declarative section index matching any raised EC. parser_match_exception(index); - auto p = declaratives->data.initial; - const auto dcls = reinterpret_cast<const cbl_declarative_t *>(p); - size_t ndcl = dcls[0].section; // overloaded // Compare returned index to each section index. - for( auto p = dcls + 1; p < dcls + 1 + ndcl; p++ ) { - parser_set_numeric( psection, p->section ); - parser_relop( yes, index, eq_op, psection ); + for( const auto& dcl : declaratives ) { + parser_set_numeric( isection, dcl.section ); + parser_relop( yes, index, eq_op, isection ); parser_if( yes ); - auto section = cbl_label_of(symbol_at(p->section)); + auto section = cbl_label_of(symbol_at(dcl.section)); parser_push_exception(); parser_perform(section); parser_pop_exception(); @@ -385,17 +320,15 @@ declarative_runtime_match( cbl_field_t *declaratives, cbl_label_t *lave ) { } } ELSE { - if( getenv("TRACE1") ) + if( getenv("GCOBOL_TRACE") ) { - gg_printf(">>>>>>( %d )(%s) __gg__exception_code is zero\n", - build_int_cst_type(INT, cobol_location().first_line), - gg_string_literal(__func__), - NULL_TREE); + gg_printf(">>>>>>( %d )(%s) __gg__exception_code is zero\n", + build_int_cst_type(INT, cobol_location().first_line), + gg_string_literal(__func__), + NULL_TREE); } } ENDIF - - parser_label_label(lave); } ec_type_t diff --git a/gcc/cobol/exceptg.h b/gcc/cobol/exceptg.h index 1cfb8df..f90cc28 100644 --- a/gcc/cobol/exceptg.h +++ b/gcc/cobol/exceptg.h @@ -36,8 +36,8 @@ extern const char * ec_type_str( ec_type_t type ); extern ec_disposition_t ec_type_disposition( ec_type_t type ); -extern void declarative_runtime_match(cbl_field_t *declaratives, - cbl_label_t *lave ); +extern void declarative_runtime_match( const std::list<cbl_declarative_t>& declaratives, + cbl_label_t *lave ); static inline ec_disposition_t ec_implemented( ec_disposition_t disposition ) { @@ -58,8 +58,8 @@ class exception_turn_t { exception_turn_t() : enabled(false), location(false) {}; - exception_turn_t( ec_type_t ec, bool enabled = true ) - : enabled(enabled) + explicit exception_turn_t( ec_type_t ec, bool enabled = true ) + : enabled(enabled), location(false) { add_exception(ec); } @@ -74,7 +74,7 @@ class exception_turn_t { const ec_filemap_t& exception_files() const { return exceptions; } - bool add_exception( ec_type_t type, const filelist_t files = filelist_t() ) { + bool add_exception( ec_type_t type, const filelist_t& files = filelist_t() ) { ec_disposition_t disposition = ec_type_disposition(type); if( disposition != ec_implemented(disposition) ) { cbl_unimplementedw("CDF: exception '%s'", ec_type_str(type)); @@ -96,9 +96,6 @@ class exception_turn_t { }; -size_t symbol_declaratives_add( size_t program, - const std::list<cbl_declarative_t>& dcls ); - #endif diff --git a/gcc/cobol/gcobc b/gcc/cobol/gcobc index 1d469ed..fa9f609 100755 --- a/gcc/cobol/gcobc +++ b/gcc/cobol/gcobc @@ -35,6 +35,10 @@ ## output set the mode variable. Everything else is appended to the ## opts variable. ## +## - -fPIC is added to the command line if $mode is "-shared". That +## option applies only to "certain machines", per the gcc info +## manual. For this script to be portable across machines, -fPIC +## would have to be set more judiciously. if [ "$COBCPY" ] then @@ -73,7 +77,7 @@ fi exit_status=0 skip_arg= -opts="$copydir ${dialect:--dialect mf} $includes" +opts="$copydir $includes" mode=-shared incomparable="has no comparable gcobol option" @@ -103,6 +107,9 @@ $0 recognizes the following GnuCOBOL cobc output mode options: $0 recognizes the following GnuCOBOL cobc compilation options: -C -d, --debug + -D + -A + -Q -E -g --coverage @@ -112,11 +119,12 @@ $0 recognizes the following GnuCOBOL cobc compilation options: --fixed -F, --free -fimplicit-init - -h, --help - -save-temps= - -save-temps - -std=mvs - -std=mf + -h, --help + -save-temps= + -save-temps + -std=mvs -std=mvs-strict + -std=mf -std=mf-strict + -std=cobol85 -std=cobol2002 -std=cobol2014 Options that are the same in gcobol and cobc are passed through verbatim. Options that have no analog in gcobol produce a warning message. To produce this message, use -HELP. @@ -127,11 +135,14 @@ To override, set the gcobol environment variable. EOF } +dialect="mf gnu" +out_set="" +first="" + # -# Simply iterate over the command-line tokens. We can't use getopts -# here because it's not designed for single-dash words (e.g. -shared). +# Iterate over the command-line tokens. We can't use getopts here +# because it's not designed for single-dash words (e.g. -shared). # - for opt in "$@" do if [ "$skip_arg" ] @@ -147,41 +158,52 @@ do ;; esac - opts="$opts $pending_arg $opt" + opts="$opts $pending_arg$opt" pending_arg= continue fi case $opt in - -A | -Q) warn "$opt" - ;; + + # pass next parameter to GCC + -A) + pending_arg=" " + ;; + + # pass next parameter to linker + -Q) + pending_arg=-Wl, + ;; + -b) mode="-shared" ;; -c) mode="-c" ;; --conf=*) warn "$opt" - ;; - -C) error "$opt $incomparable" - ;; - -d | --debug) opts="$opts -fcobol-exceptions=EC-ALL" - warn "$opt implies -fstack-check:" - ;; - # -D - -E) opts="$opts $opt -fsyntax-only" + ;; + -C) error "$opt $incomparable" + ;; + -d | -debug | --debug) opts="$opts -fcobol-exceptions=EC-ALL" + warn "$opt implies -fstack-check:" + ;; + # define for preprocessor, note: -D* is directly passed + -D) + pending_arg=$opt ;; - -echo) echo="echo" + -E) opts="$opts $opt -fsyntax-only" + ;; + -echo) echo="echo" ;; -fec=* | -fno-ec=*) opt="$(echo "$opt" | sed -E 's/-f(no-)?ec=/-f\1cobol-exceptions=EC-/g')" - opts="$opts $opt" - ;; - -ext) - pending_arg=$opt - ;; - -ext=*) opts="$opts $(echo "$opt" | sed 's/-ext=/-copyext ./')" - ;; - + opts="$opts $opt" + ;; + -ext) + pending_arg="$opt " + ;; + -ext=*) opts="$opts $(echo "$opt" | sed 's/-ext=/-copyext ./')" + ;; # A.3 Compiler options -fsign=*) warn "$opt" ;; -ffold-copy=*) warn "$opt" ;; @@ -359,19 +381,18 @@ do -fnot-register=*) warn "$opt" ;; -fregister=*) warn "$opt" ;; - -fformat=auto ) ;; # gcobol and gnucobol default + -fformat=auto) ;; # gcobol and gnucobol default -fixed | --fixed | -fformat=fixed | -fformat=variable | -fformat=xcard) # note: variable + xcard are only _more similar_ to fixed than free, # (with changing right-column to 250/255, which isn't supported in gcobol, yet) - opts="$opts -ffixed-form" - ;; - - -F | -free | --free | -fformat=free | -fformat=* ) - # note: "all other formats" are only _more similar_ to free than fixed - opts="$opts -ffree-form" - ;; + opts="$opts -ffixed-form" + ;; + -F | -free | --free | -fformat=free | -fformat=*) + # note: "all other formats" are only _more similar_ to free than fixed + opts="$opts -ffree-form" + ;; -h | --help) opts="$opts --help" ;; @@ -413,24 +434,37 @@ do export GCOBOL_TEMPDIR="$opt" ;; -save-temps) export GCOBOL_TEMPDIR="${PWD:-$(pwd)}" - ;; - # -shared is identical + ;; + # -shared is identical - -std=mvs) opts="$opts -dialect ibm" + -std=mvs | -std=mvs-strict | -std=ibm | -std=ibm-strict) dialect=ibm ;; - -std=mf) opts="$opts -dialect mf" + -std=mf | -std=mf-strict) dialect=mf + ;; + # GnuCOBOL's default and GCC's dialect for GnuCOBOL + -std=default) dialect=gnu + ;; + # GCC COBOL targets COBOL2024 "mostly backward to COBOL85" + -std=cobol*) dialect="" + ;; + -std=*) + dialect="" + warn "$opt (unkown dialect)" ;; - -t | -T | -tlines=* | -P | -P=* | -X | --Xref) - warn "$opt (no listing)" + -P | -P=* | -X | --Xref) + warn "$opt (no listing)" + ;; + -t | -T) + # note: -P has an _optional_ arg, so we leave it above + ignore_arg "$opt (no listing)" + ;; + -q | --brief) warn "$opt" + ;; + -v | --verbose) opts="$opts -V" + ;; + # note: we want -dumpversion to be passed to gcc + -V | --version | -version) opts="$opts --version" ;; - -q | --brief) warn "$opt" - ;; - -v | --verbose) opts="$opts -V" - ;; - # note: we want -dumpversion to be passed to gcc - -V | --version | -version) opts="$opts --version" - ;; - # pass through, strangely -Wall is not supported -w | -W | -Wextra) opts="$opts $opt" ;; @@ -447,14 +481,16 @@ do opts="$opts /dev/stdin" ;; - *) if [ -z "$output_name" ] # first non-option argument is source file name + # First file name argument is default output filename. + *) if [ -z "$output_name" -a -e "$opt" ] then - output_name=$(basename ${opt%.*}) + output_name=$(basename "${opt%.*}") case $mode in -c) output_name="$output_name".o ;; -shared) output_name="$output_name".so + opts="$opts -fPIC" ;; esac opts="$opts -o $output_name" @@ -478,6 +514,11 @@ fi # To override the default gcobol, set the "gcobol" environment variable. gcobol="${gcobol:-${0%/*}/gcobol}" +if [ "$dialect" ] +then + dialect=$(echo $dialect | sed -E 's/[[:alnum:]]+/-dialect &/g') +fi + if [ "$echo" ] then echo $gcobol $mode $opts @@ -489,4 +530,4 @@ then set -x fi -exec $gcobol $mode $opts +exec $gcobol $mode $dialect $opts diff --git a/gcc/cobol/gcobol.1 b/gcc/cobol/gcobol.1 index 0c3d2c1..ebb833c 100644 --- a/gcc/cobol/gcobol.1 +++ b/gcc/cobol/gcobol.1 @@ -39,7 +39,7 @@ compiles \*[lang] source code to object code, and optionally produces an executable binary or shared object. As a GCC component, it accepts all options that affect code-generation and linking. Options specific to \*[lang] are listed below. -.Bl -tag -width \0\0debug +.Bl -tag -width "\0\0debug" .It Fl main Ar filename .Nm will generate a @@ -197,14 +197,12 @@ Otherwise, columns 1-6 are examined. If those characters are all digits or blanks, the file is assumed to be in .Em "fixed-form reference format", also with the indicator in column 7. - If not auto-detected as .Em "fixed-form reference format" or .Em "extended source format", the file is assumed to be in .Em "free-form reference format". - .Pp . .It Fl fcobol-exceptions Ar exception Op Ns , Ns Ar exception Ns ... @@ -589,6 +587,21 @@ statement, regardless of compile-time constants. .. . .Ss Implemented Exception Conditions +By default, per ISO, no EC is enabled. Implemented ECs may be enabled +on the command line or via the +.Sy TURN +directive. Any attempt to enable an EC that is not implemented is +treated as an error. +.Pp +An enabled EC not handled by a +.Sy DECLARATIVE +is written to the system log and to standard error. (The authors +intend to make that an option.) A fatal EC not handled with +.Sy RESUME +ends with a call to +.Xr abort 3 +and process termination. +.Pp Not all Exception Conditions are implemented. Any attempt to enable an EC that that is not implemented produces a warning message. The following are implemented: @@ -915,11 +928,90 @@ or has no effect; the two are interchangeable. .. . -.Ss Compiler-Directing Facility (CDF) +.Sh COMPILER-DIRECTING FACILITY The CDF should be used with caution because no comprehensive test -suite has been identified. +suite has been identified. . -.Ss Conditional Compilation +.Ss CDF Text Manipulation +.Bl -tag -width >>DEFINE +.It Sy COPY Ar copybook Li Oo OF|BY Ar library Oc Oo Sy REPLACING ... Oc +If +.Ar copybook +is a literal, it treated a literal filename, which either does or does not exist. If +.Ar copybook +is a \*[lang] word, +.Nm +looks first for an environment variable named +.Va copybook +and, if found, uses the contents of that variable as the name of the +copybook file. If that file does not exist, it continues looking for +a file named one of: +.sp +.Bl -bullet -compact -offset 5n +.It +.Pa copybook +(literally) +.It +.Pa copybook.cpy +.It +.Pa copybook.CPY +.It +.Pa copybook.cbl +.It +.Pa copybook.CBL +.It +.Pa copybook.cob +.It +.Pa copybook.COB +.El +.sp +in that order. It looks first in the same directory as the source +code file, and then in any +.Ar copybook-path +named with the +.Fl I +option. +. +.\" FIXME: need escape mechanism for directories with ':' in the name. +.Ar copybook-path +may (like the shell's +.Ev PATH +variable) be a colon-separated list. +The +.Fl I +option may occur multiple times on the command line. Each successive +.Ar copybook-path +is concatenated to previous ones. +Relative paths (having no leading +.Ql / Ns +\&) +are searched relative to the compiler's current working directory. +.Pp +For example, +.D1 \& +.D1 Fl I Li /usr/local/include:include +.D1 \& +searches first the directory where the \*[lang] program is found, next in +.Pa /usr/local/include , +and finally in an +.Pa include +subdirectory of the directory from which +.Nm +was invoked. +.Pp +For the +.Sy REPLACING +phrase, both the modern pseudo-text and the \*[lang]/85 forms are +recognized. (The older forms are used in the NIST CCVS/85 test suite.) +.It Sy REPLACE ... +.Nm +supports the full ISO +.Sy REPLACE +syntax. +.El +. +.Ss CDF Directives +.\"Bl -tag -width >>PROPAGATE .Bl -tag -width >>DEFINE .It >> Ns Sy DEFINE Ar name Sy AS Bro Ar expression Li | Sy PARAMETER Brc Op Sy OVERRIDE Define @@ -961,10 +1053,6 @@ is supported. Boolean literals are not supported. . .It >> Ns Sy EVALUATE Not implemented. -.El -. -.Ss Other CDF Directives -.Bl -tag -width >>PROPAGATE .It >> Ns Sy CALL-CONVENTION Ar convention .Ar convention may be one of: @@ -1038,6 +1126,24 @@ Not implemented. Not implemented. .It >> Ns Sy PROPAGATE Not implemented. +.It >> Ns Sy PUSH Ar directive +.It >> Ns Sy POP Ar directive +With +.Sy PUSH , +push CDF state onto a stack. +With +.Sy POP , +return to the prior pushed state. +.Ar directive +may be one of +.Bl -tag -compact +.It Sy CALL-CONVENTION +.It Sy COBOL-WORDS +.It Sy DEFINE +.It Sy SOURCE FORMAT +.It Sy TURN +.El +. .It >> Ns Sy TURN Oo .Ar ec Oo Ar file Li ... Oc ... .Oc Sy CHECKING Bro Oo Sy ON Oc Oo Oo Sy WITH Oc Sy LOCATION Oc | Sy OFF Brc @@ -1088,76 +1194,6 @@ the directive must appear before .Pp To test a feature-set variable, use .Dl >>IF Ar feature Li DEFINED -.. -.Ss Copybooks -.Nm -supports the CDF -.Sy COPY -statement, with or without its -.Sy REPLACING -component. For any statement -.sp -.D1 COPY Ar copybook -.sp -.Nm -looks first for an environment variable named -.Va copybook -and, if found, uses the contents of that variable as the name of the -copybook file. If that file does not exist, it continues looking for -a file named one of: -.sp -.Bl -bullet -compact -offset 5n -.It -.Pa copybook -(literally) -.It -.Pa copybook.cpy -.It -.Pa copybook.CPY -.It -.Pa copybook.cbl -.It -.Pa copybook.CBL -.It -.Pa copybook.cob -.It -.Pa copybook.COB -.El -.sp -in that order. It looks first in the same directory as the source -code file, and then in any -.Ar copybook-path -named with the -.Fl I -option. -. -.\" FIXME: need escape mechanism for directories with ':' in the name. -.Ar copybook-path -may (like the shell's -.Ev PATH -variable) be a colon-separated list. -. -The -.Fl I -option may occur multiple times on the command line. Each successive -.Ar copybook-path -is concatenated to previous ones. -Relative paths (having no leading -.Ql / Ns -\&) -are searched relative to the compiler's current working directory. -.Pp -For example, -.D1 \& -.D1 Fl I Li /usr/local/include:include -.D1 \& -searches first the directory where the \*[lang] program is found, next in -.Pa /usr/local/include , -and finally in an -.Pa include -subdirectory of the directory from which -.Nm -was invoked. . .Ss Intrinsic functions .Nm @@ -1167,54 +1203,54 @@ others. They are listed alphabetically below. .It ABS ACOS ANNUITY ASIN ATAN .It -BASECONVERT BIT_OF BIT_TO_CHAR BOOLEAN_OF_INTEGER BYTE_LENGTH +BASECONVERT BIT-OF BIT-TO-CHAR BOOLEAN-OF-INTEGER BYTE-LENGTH .It -CHAR CHAR_NATIONAL COMBINED_DATETIME CONCAT CONVERT COS CURRENT_DATE +CHAR CHAR-NATIONAL COMBINED-DATETIME CONCAT CONVERT COS CURRENT-DATE .It -DATE_OF_INTEGER DATE_TO_YYYYMMDD DAY_OF_INTEGER DAY_TO_YYYYDDD DISPLAY_OF +DATE-OF-INTEGER DATE-TO-YYYYMMDD DAY-OF-INTEGER DAY-TO-YYYYDDD DISPLAY-OF .It -E EXCEPTION_FILE -EXCEPTION_FILE_N EXCEPTION_LOCATION EXCEPTION_LOCATION_N -EXCEPTION_STATEMENT EXCEPTION_STATUS EXP EXP10 +E EXCEPTION-FILE +EXCEPTION-FILE-N EXCEPTION-LOCATION EXCEPTION-LOCATION-N +EXCEPTION-STATEMENT EXCEPTION-STATUS EXP EXP10 .It -FACTORIAL FIND_STRING -FORMATTED_CURRENT_DATE FORMATTED_DATE FORMATTED_DATETIME -FORMATTED_TIME FRACTION_PART +FACTORIAL FIND-STRING +FORMATTED-CURRENT-DATE FORMATTED-DATE FORMATTED-DATETIME +FORMATTED-TIME FRACTION-PART .It -HEX_OF HEX_TO_CHAR HIGHEST_ALGEBRAIC +HEX-OF HEX-TO-CHAR HIGHEST-ALGEBRAIC .It -INTEGER INTEGER_OF_BOOLEAN INTEGER_OF_DATE INTEGER_OF_DAY -INTEGER_OF_FORMATTED_DATE INTEGER_PART +INTEGER INTEGER-OF-BOOLEAN INTEGER-OF-DATE INTEGER-OF-DAY +INTEGER-OF-FORMATTED-DATE INTEGER-PART .It -LENGTH LOCALE_COMPARE -LOCALE_DATE LOCALE_TIME LOCALE_TIME_FROM_SECONDS LOG LOG10 LOWER_CASE -LOWEST_ALGEBRAIC +LENGTH LOCALE-COMPARE +LOCALE-DATE LOCALE-TIME LOCALE-TIME-FROM-SECONDS LOG LOG10 LOWER-CASE +LOWEST-ALGEBRAIC .It -MAX MEAN MEDIAN MIDRANGE MIN MOD MODULE_NAME +MAX MEAN MEDIAN MIDRANGE MIN MOD MODULE-NAME .It -NATIONAL_OF NUMVAL NUMVAL_C NUMVAL_F ORD +NATIONAL-OF NUMVAL NUMVAL-C NUMVAL-F ORD .It -ORD_MAX ORD_MIN +ORD-MAX ORD-MIN .It -PI PRESENT_VALUE +PI PRESENT-VALUE .It RANDOM RANGE REM REVERSE .It -SECONDS_FROM_FORMATTED_TIME -SECONDS_PAST_MIDNIGHT SIGN SIN SMALLEST_ALGEBRAIC SQRT -STANDARD_COMPARE STANDARD_DEVIATION SUBSTITUTE SUM +SECONDS-FROM-FORMATTED-TIME +SECONDS-PAST-MIDNIGHT SIGN SIN SMALLEST-ALGEBRAIC SQRT +STANDARD-COMPARE STANDARD-DEVIATION SUBSTITUTE SUM .It -TAN TEST_DATE_YYYYMMDD TEST_DAY_YYYYDDD TEST_FORMATTED_DATETIME -TEST_NUMVAL TEST_NUMVAL_C TEST_NUMVAL_F TRIM +TAN TEST-DATE-YYYYMMDD TEST-DAY-YYYYDDD TEST-FORMATTED-DATETIME +TEST-NUMVAL TEST-NUMVAL-C TEST-NUMVAL-F TRIM .It -ULENGTH UPOS UPPER_CASE +ULENGTH UPOS UPPER-CASE USUBSTR USUPPLEMENTARY UUID4 UVALID UWIDTH .It VARIANCE .It -WHEN_COMPILED +WHEN-COMPILED .It -YEAR_TO_YYYY +YEAR-TO-YYYY .El . .Ss Binary floating point DISPLAY @@ -1294,7 +1330,7 @@ stores and converts numbers. Converting the floating-point value to the numeric display value 0055110 is done by multiplying 55.109999...\& by 1,000 and then truncating the result to an integer. And it turns out that even -though 55.11 can’t be represented in floating-point as an exact value, +though 55.11 can't be represented in floating-point as an exact value, the product of the multiplication, 55110, is an exact value. .Pp In cases where it is important for conversions to have predictable @@ -1325,7 +1361,7 @@ specified for a calculation, then the intermediate result becomes a . .Ss A warning about binary floating point comparison The cardinal rule when doing comparisons involving floating-point -values: Never, ever, test for equality. It’s just not worth the hassle. +values: Never, ever, test for equality. It's just not worth the hassle. .Pp For example: .Bd -literal @@ -1361,7 +1397,7 @@ and you really test the code. And then avoid it anyway. .Pp Finally, it is observably the case that the .Nm -implementations of floating-point conversions and comparisons don’t +implementations of floating-point conversions and comparisons don't precisely match the behavior of other \*[lang] compilers. .Pp You have been warned. diff --git a/gcc/cobol/gcobolspec.cc b/gcc/cobol/gcobolspec.cc index d1ffc97..1f1b463 100644 --- a/gcc/cobol/gcobolspec.cc +++ b/gcc/cobol/gcobolspec.cc @@ -82,7 +82,7 @@ static bool need_libgcobol = true; // #define NOISY 1 static void -append_arg(const struct cl_decoded_option arg) +append_arg(const cl_decoded_option& arg) { #ifdef NOISY static int counter = 1; @@ -142,9 +142,6 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, int n_infiles = 0; int n_outfiles = 0; - // The number of input files when the language is "none" or "cobol" - int n_cobol_files = 0; - // saw_OPT_no_main means "don't expect -main" bool saw_OPT_no_main = false; @@ -234,11 +231,6 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, case OPT_SPECIAL_input_file: no_files_error = false; n_infiles += 1; - if( strcmp(language, "none") == 0 - || strcmp(language, "cobol") == 0 ) - { - n_cobol_files += 1; - } if( strstr(decoded_options[i].orig_option_with_args_text, "libgcobol.a") ) { // We have been given an explicit libgcobol.a. We need to note that. @@ -478,7 +470,10 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, //// break; ////#endif case OPT_static: +#if defined (HAVE_LD_STATIC_DYNAMIC) + append_arg(decoded_options[i]); static_in_general = true; +#endif break; default: @@ -506,17 +501,23 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, need_libgcobol = false; } + if( static_in_general ) + { + // These two options interfere with each other. + static_libgcobol = false; + } + if( need_libgcobol ) { add_arg_lib(COBOL_LIBRARY, static_libgcobol); } if( need_libdl ) { - add_arg_lib(DL_LIBRARY, static_in_general); + add_arg_lib(DL_LIBRARY, false); } if( need_libstdc ) { - add_arg_lib(STDCPP_LIBRARY, static_in_general); + add_arg_lib(STDCPP_LIBRARY, false); } if( prior_main ) @@ -529,7 +530,8 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, // cl_decoded_option size_t new_option_count = new_opt.size(); - struct cl_decoded_option *new_options = XNEWVEC (struct cl_decoded_option, new_option_count); + struct cl_decoded_option *new_options = XNEWVEC (struct cl_decoded_option, + new_option_count); for(size_t i=0; i<new_option_count; i++) { @@ -539,7 +541,7 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, #ifdef NOISY verbose = true; #endif - if( verbose && new_options != original_options ) + if( verbose && new_options != original_options ) // cppcheck-suppress knownConditionTrueFalse { fprintf(stderr, _("Driving: (" HOST_SIZE_T_PRINT_DEC ")\n"), (fmt_size_t)new_option_count); diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 70df86a..c9d2da4 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -27,6 +27,7 @@ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ + #include "cobol-system.h" #include "coretypes.h" @@ -60,7 +61,8 @@ extern int yylineno; #define TSI_BACK (tsi_last(current_function->statement_list_stack.back())) extern char *cobol_name_mangler(const char *cobol_name); -static tree gg_attribute_bit_get(struct cbl_field_t *var, cbl_field_attr_t bits); +static tree gg_attribute_bit_get( struct cbl_field_t *var, + cbl_field_attr_t bits); static tree label_list_out_goto; static tree label_list_out_label; @@ -80,6 +82,8 @@ bool bSHOW_PARSE = getenv("GCOBOL_SHOW"); bool show_parse_sol = true; int show_parse_indent = 0; +static bool sv_is_i_o = false; + #define DEFAULT_LINE_NUMBER 2 #ifdef LINE_TICK @@ -114,7 +118,7 @@ typedef struct TREEPLET static void -treeplet_fill_source(TREEPLET &treeplet, cbl_refer_t &refer) +treeplet_fill_source(TREEPLET &treeplet, const cbl_refer_t &refer) { treeplet.pfield = gg_get_address_of(refer.field->var_decl_node); treeplet.offset = refer_offset(refer); @@ -123,8 +127,8 @@ treeplet_fill_source(TREEPLET &treeplet, cbl_refer_t &refer) tree file_static_variable(tree type, const char *v) { - // This routine returns a reference to an already-defined file_static variable - // You need to know the type that was used for the definition. + // This routine returns a reference to an already-defined file_static + // variable. You need to know the type that was used for the definition. return gg_declare_variable(type, v, NULL, vs_file_static); } @@ -140,9 +144,9 @@ static void move_helper(tree size_error, // INT // set using -f-trace-debug, defined in lang.opt int f_trace_debug; -// When doing WRITE statements, the IBM Language Reference and the ISO/IEC_2014 -// standard specify that when the ADVANCING clause is omitted, the default is -// AFTER ADVANCING 1 LINE. +// When doing WRITE statements, the IBM Language Reference and the +// ISO/IEC_2014 standard specify that when the ADVANCING clause is omitted, the +// default isAFTER ADVANCING 1 LINE. // // MicroFocus and GnuCOBOL state that the default is BEFORE ADVANCING 1 LINE // @@ -187,6 +191,9 @@ const char *gv_trace_switch = NULL; char const *bTRACE1 = NULL; tree trace_handle; tree trace_indent; + +// This variable is set to true when the output cursor is known to be at the +// start-of-line. bool cursor_at_sol = true; static void @@ -199,7 +206,7 @@ trace1_init() trace_handle = gg_define_variable(INT, "trace_handle", vs_static); trace_indent = gg_define_variable(INT, "trace_indent", vs_static); - bTRACE1 = getenv("GCOBOL_TRACE") ? getenv("GCOBOL_TRACE") : gv_trace_switch; + bTRACE1 = getenv("GCOBOL_TRACE") ? getenv("GCOBOL_TRACE") :gv_trace_switch; if( bTRACE1 && strcmp(bTRACE1, "0") != 0 ) { @@ -226,6 +233,13 @@ trace1_init() } } +static +void +insert_nop(int n) + { + gg_assign(var_decl_nop, build_int_cst_type(INT, n)); + } + static void create_cblc_string_variable(const char *var_name, const char *var_contents) { @@ -263,13 +277,22 @@ build_main_that_calls_something(const char *something) SHOW_PARSE_END } - gg_set_current_line_number(DEFAULT_LINE_NUMBER); + tree function_decl = gg_define_function( INT, + "main", + "main", + INT, "argc", + build_pointer_type(CHAR_P), "argv", + NULL_TREE); - gg_define_function( INT, - "main", - INT, "argc", - build_pointer_type(CHAR_P), "argv", - NULL_TREE); + // Modify the default settings for main(), as empirically determined from + // examining C/C+_+ compilations. (See the comment for gg_build_fn_decl()). + TREE_ADDRESSABLE(function_decl) = 0; + TREE_USED(function_decl) = 0; + TREE_NOTHROW(function_decl) = 0; + TREE_STATIC(function_decl) = 1; + DECL_EXTERNAL (function_decl) = 0; + TREE_PUBLIC (function_decl) = 1; + DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 1; // Pick up pointers to the input parameters: // First is the INT which is the number of argv[] entries @@ -307,7 +330,6 @@ build_main_that_calls_something(const char *something) argc, argv, NULL_TREE))); - strncpy(ach_cobol_entry_point, psz, sizeof(ach_cobol_entry_point)-1); free(psz); gg_finalize_function(); } @@ -347,8 +369,11 @@ level_88_helper(size_t parent_capacity, size_t &returned_size) { // We return a MALLOCed return value, which the caller must free. - char *retval = (char *)xmalloc(parent_capacity + 64); - char *builder = (char *)xmalloc(parent_capacity + 64); + char *retval = static_cast<char *>(xmalloc(parent_capacity + 64)); + gcc_assert(retval); + char *builder = static_cast<char *>(xmalloc(parent_capacity + 64)); + gcc_assert(builder); + size_t nbuild = 0; cbl_figconst_t figconst = cbl_figconst_of( elem.name()); @@ -389,7 +414,8 @@ level_88_helper(size_t parent_capacity, // Pick up the string size_t first_name_length = elem.size(); - char *first_name = (char *)xmalloc(first_name_length + 1); + char *first_name = static_cast<char *>(xmalloc(first_name_length + 1)); + gcc_assert(first_name); memcpy(first_name, elem.name(), first_name_length); first_name[first_name_length] = '\0'; @@ -466,7 +492,7 @@ get_level_88_domain(size_t parent_capacity, cbl_field_t *var, size_t &returned_s // Numerics are converted to strings, and handled as above size_t retval_capacity = 64; - char *retval = (char *)xmalloc(retval_capacity); + char *retval = static_cast<char *>(xmalloc(retval_capacity)); size_t output_index = 0; // Loop through the provided domains: @@ -483,8 +509,9 @@ get_level_88_domain(size_t parent_capacity, cbl_field_t *var, size_t &returned_s if( output_index + stream_len > retval_capacity ) { retval_capacity *= 2; - retval = (char *)xrealloc(retval, retval_capacity); + retval = static_cast<char *>(xrealloc(retval, retval_capacity)); } + gcc_assert(retval); memcpy(retval + output_index, stream, stream_len); output_index += stream_len; returned_size += stream_len; @@ -495,14 +522,23 @@ get_level_88_domain(size_t parent_capacity, cbl_field_t *var, size_t &returned_s if( output_index + stream_len > retval_capacity ) { retval_capacity *= 2; - retval = (char *)xrealloc(retval, retval_capacity); + retval = static_cast<char *>(xrealloc(retval, retval_capacity)); } + gcc_assert(retval); memcpy(retval + output_index, stream, stream_len); output_index += stream_len; returned_size += stream_len; free(stream); domain += 1; } + + if( returned_size >= retval_capacity) + { + retval_capacity *= 2; + retval = static_cast<char *>(xrealloc(retval, retval_capacity)); + } + + gcc_assert(returned_size < retval_capacity); retval[returned_size++] = '\0'; return retval; } @@ -569,7 +605,7 @@ get_class_condition_string(cbl_field_t *var) { if( strlen(ach) > sizeof(ach) - 1000 ) { - cbl_internal_error("Nice try, but you can't fire me. I quit!"); + cbl_internal_error("Nice try, but you cannot fire me."); } // We are working with unquoted strings that contain the values 1 through @@ -594,13 +630,8 @@ get_class_condition_string(cbl_field_t *var) // Since the first.name is a single character, we can do this as // a single-character pair. - // Keep in mind that the single character might be a two-byte UTF-8 - // codepoint - uint8_t ch1 = domain->first.name()[0]; - uint8_t ch2 = domain->last.name()[0]; - - gcc_assert(first_name_length <= 2); - gcc_assert(last_name_length <= 2); + uint8_t ch1; + uint8_t ch2; char *p2; size_t one; @@ -692,30 +723,42 @@ struct called_tree_t { tree node; public: - match_tree( tree node ) : node(node) {} + explicit match_tree( tree node ) : node(node) {} bool operator()( const called_tree_t& that ) const { return this->node == that.node; } }; }; -static std::map<program_reference_t, std::list<called_tree_t> > call_targets; +static std::map<program_reference_t, std::list<tree> > call_targets; static std::map<tree, cbl_call_convention_t> called_targets; -static void -parser_call_target( tree func ) +static +void +set_call_convention(tree function_decl, cbl_call_convention_t convention) { - cbl_call_convention_t convention = current_call_convention(); - const char *name = IDENTIFIER_POINTER( DECL_NAME(func) ); - program_reference_t key(current_program_index(), name); - - // Each func is unique and inserted only once. - assert( called_targets.find(func) == called_targets.end() ); - called_targets[func] = convention; + called_targets[function_decl] = convention; + } - called_tree_t value(func, convention); - auto& p = call_targets[key]; - p.push_back(value); +static +void +parser_call_target( const char *name, tree call_expr ) + { + /* This routine gets called when parser_call() has been invoked with a + literal target. That target is a COBOL name like "prog_2". However, + there is the case when "prog_2" is a forward reference to a contained + program nested inside "prog_1". In that case, the actual definition + of "prog_2" will end up with a name like "prog_2.62", and eventually + the target of the call will have to be modified from "prog_2" to + "prog_2.62". + + We save the call expression for this call, and then we update it later, + after we know whether or not it was a forward reference to a local + function. */ + + program_reference_t key(current_program_index(), name); + auto& p = call_targets[key]; + p.push_back(call_expr); } /* @@ -727,17 +770,23 @@ parser_call_target( tree func ) cbl_call_convention_t parser_call_target_convention( tree func ) { - auto p = called_targets.find(func); - if( p != called_targets.end() ) return p->second; + auto p = called_targets.find(func); + if( p != called_targets.end() ) + { + // This was found in our list of call targets + return p->second; + } - return cbl_call_cobol_e; + return cbl_call_cobol_e; } void parser_call_targets_dump() { - dbgmsg( "call targets for #" HOST_SIZE_T_PRINT_UNSIGNED, + dbgmsg( "call targets for #" HOST_SIZE_T_PRINT_UNSIGNED " NOT dumping", (fmt_size_t)current_program_index() ); +#if 0 // A change to call_targets rendered this routine useless. Until we get + // around to repairing it, this code is left for reference. for( const auto& elem : call_targets ) { const auto& k = elem.first; const auto& v = elem.second; @@ -746,11 +795,12 @@ parser_call_targets_dump() k.called); char ch = '['; for( auto func : v ) { - fprintf( stderr, "%c %s", ch, IDENTIFIER_POINTER(DECL_NAME(func.node)) ); + fprintf( stderr, "%c %s", ch, IDENTIFIER_POINTER(DECL_NAME(func)) ); ch = ','; } fprintf(stderr, " ]\n"); } +#endif } size_t @@ -758,21 +808,28 @@ parser_call_target_update( size_t caller, const char plain_name[], const char mangled_name[] ) { - auto key = program_reference_t(caller, plain_name); - auto p = call_targets.find(key); - if( p == call_targets.end() ) return 0; + auto key = program_reference_t(caller, plain_name); + auto p = call_targets.find(key); + if( p == call_targets.end() ) return 0; - for( auto func : p->second ) - { - func.convention = cbl_call_verbatim_e; - DECL_NAME(func.node) = get_identifier(mangled_name); - } - return p->second.size(); + for( auto call_expr : p->second ) + { + tree fndecl_type = build_varargs_function_type_array( COBOL_FUNCTION_RETURN_TYPE, + 0, // No parameters yet + NULL); // And, hence, no types + + // Fetch the FUNCTION_DECL for that FUNCTION_TYPE + tree function_decl = gg_build_fn_decl(mangled_name, fndecl_type); + tree function_address = gg_get_address_of(function_decl); + + TREE_OPERAND(call_expr, 1) = function_address; + } + return p->second.size(); } static tree -function_handle_from_name(cbl_refer_t &name, - tree function_return_type) +function_pointer_from_name(const cbl_refer_t &name, + tree function_return_type) { Analyze(); @@ -780,74 +837,76 @@ function_handle_from_name(cbl_refer_t &name, function_return_type, 0, NULL); - tree function_pointer = build_pointer_type(function_type); - tree function_handle = gg_define_variable(function_pointer, "..function_handle.1", vs_stack); - + tree function_pointer_type = build_pointer_type(function_type); + tree function_pointer = gg_define_variable(function_pointer_type, + "..function_pointer.1", + vs_stack); if( name.field->type == FldPointer ) { // If the parameter is a pointer, just pick up the value and head for the // exit if( refer_is_clean(name) ) { - gg_memcpy(gg_get_address_of(function_handle), + gg_memcpy(gg_get_address_of(function_pointer), member(name.field->var_decl_node, "data"), sizeof_pointer); } else { - gg_memcpy(gg_get_address_of(function_handle), + gg_memcpy(gg_get_address_of(function_pointer), qualified_data_location(name), sizeof_pointer); } - return function_handle; + return function_pointer; } else if( use_static_call() && is_literal(name.field) ) { - // It's a literal, and we are using static calls. Generate the CALL, and - // pass the address expression to parser_call_target(). That will cause - // parser_call_target_update() to replace any nested CALL "foo" with the - // local "foo.60" name. + tree fndecl_type = build_varargs_function_type_array( function_return_type, + 0, // No parameters yet + NULL); // And, hence, no types - // We create a reference to it, which is later resolved by the linker. - tree addr_expr = gg_get_function_address( function_return_type, - name.field->data.initial); - gg_assign(function_handle, addr_expr); - - tree func = TREE_OPERAND(addr_expr, 0); - parser_call_target(func); // add function to list of call targets + // Fetch the FUNCTION_DECL for that FUNCTION_TYPE + tree function_decl = gg_build_fn_decl(name.field->data.initial, + fndecl_type); + // Take the address of the function decl: + tree address_of_function = gg_get_address_of(function_decl); + gg_assign(function_pointer, address_of_function); } else { - // This is not a literal or static + // We are not using static calls. if( name.field->type == FldLiteralA ) { - gg_assign(function_handle, + gg_assign(function_pointer, gg_cast(build_pointer_type(function_type), - gg_call_expr(VOID_P, - "__gg__function_handle_from_literal", - build_int_cst_type(INT, current_function->our_symbol_table_index), - gg_string_literal(name.field->data.initial), - NULL_TREE))); + gg_call_expr( VOID_P, + "__gg__function_handle_from_literal", + build_int_cst_type(INT, + current_function->our_symbol_table_index), + gg_string_literal(name.field->data.initial), + NULL_TREE))); } else { - gg_assign(function_handle, + gg_assign(function_pointer, gg_cast(build_pointer_type(function_type), gg_call_expr( VOID_P, - "__gg__function_handle_from_name", - build_int_cst_type(INT, current_function->our_symbol_table_index), - gg_get_address_of(name.field->var_decl_node), - refer_offset(name), - refer_size_source( name), - NULL_TREE))); + "__gg__function_handle_from_name", + build_int_cst_type(INT, + current_function->our_symbol_table_index), + gg_get_address_of(name.field->var_decl_node), + refer_offset(name), + refer_size_source( name), + NULL_TREE))); } } - return function_handle; + return function_pointer; } void -parser_initialize_programs(size_t nprogs, struct cbl_refer_t *progs) +parser_initialize_programs( size_t nprogs, + const struct cbl_refer_t *progs) { Analyze(); SHOW_PARSE @@ -877,11 +936,11 @@ parser_initialize_programs(size_t nprogs, struct cbl_refer_t *progs) for( size_t i=0; i<nprogs; i++ ) { - tree function_handle = function_handle_from_name( progs[i], - COBOL_FUNCTION_RETURN_TYPE); + tree function_pointer = function_pointer_from_name( progs[i], + COBOL_FUNCTION_RETURN_TYPE); gg_call(VOID, "__gg__to_be_canceled", - gg_cast(SIZE_T, function_handle), + gg_cast(SIZE_T, function_pointer), NULL_TREE); } } @@ -933,25 +992,37 @@ array_of_long_long(const char *name, const std::vector<uint64_t>& vals) * Performs the matched declarative, and execution continues with the next * statement. */ -tree parser_compile_ecs( const std::vector<uint64_t>& ecs ) +tree +parser_compile_ecs( const std::vector<uint64_t>& ecs ) { - char ach[32]; + if( ecs.empty() ) + { + SHOW_IF_PARSE(nullptr) + { + SHOW_PARSE_HEADER + SHOW_PARSE_TEXT("ecs is empty"); + SHOW_PARSE_END + } + return NULL_TREE; + } + + char ach[64]; static int counter = 1; sprintf(ach, "_ecs_table_%d", counter++); tree retval = array_of_long_long(ach, ecs); SHOW_IF_PARSE(nullptr) { SHOW_PARSE_HEADER - char ach[64]; - snprintf(ach, sizeof(ach), " Size is %ld; retval is %p", ecs.size(), retval); + snprintf(ach, sizeof(ach), " Size is %lu; retval is %p", + gb4(ecs.size()), as_voidp(retval)); SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } TRACE1 { TRACE1_HEADER - char ach[64]; - snprintf(ach, sizeof(ach), " Size is %ld; retval is %p", ecs.size(), retval); + snprintf(ach, sizeof(ach), " Size is %lu; retval is %p", + gb4(ecs.size()), as_voidp(retval)); TRACE1_TEXT_ABC("", ach, ""); TRACE1_END } @@ -968,37 +1039,100 @@ tree parser_compile_ecs( const std::vector<uint64_t>& ecs ) * invoked, and thus the set of active Declaratives. By passing them for each * statement, code generation is relieved of referring to global variable. */ -tree parser_compile_dcls( const std::vector<uint64_t>& dcls ) +tree +parser_compile_dcls( const std::vector<uint64_t>& dcls ) { - char ach[32]; + if( dcls.empty() ) + { + SHOW_IF_PARSE(nullptr) + { + SHOW_PARSE_HEADER + SHOW_PARSE_TEXT("dcls is empty"); + SHOW_PARSE_END + } + return NULL_TREE; + } + + char ach[64]; static int counter = 1; sprintf(ach, "_dcls_table_%d", counter++); - tree retval = array_of_long_long(ach, dcls); SHOW_IF_PARSE(nullptr) { SHOW_PARSE_HEADER - char ach[64]; - snprintf(ach, sizeof(ach), " Size is %ld; retval is %p", dcls.size(), retval); + snprintf(ach, sizeof(ach), " Size is %lu; retval is %p", + gb4(dcls.size()), as_voidp(retval)); SHOW_PARSE_TEXT(ach); SHOW_PARSE_END } - TRACE1 { TRACE1_HEADER - char ach[64]; - snprintf(ach, sizeof(ach), " Size is %ld; retval is %p", dcls.size(), retval); + snprintf(ach, sizeof(ach), " Size is %lu; retval is %p", + gb4(dcls.size()), as_voidp(retval)); TRACE1_TEXT_ABC("", ach, ""); TRACE1_END } return retval; } -static void store_location_stuff(const cbl_name_t statement_name); +static void +store_location_stuff(const cbl_name_t statement_name) + { + if( exception_location_active && !current_declarative_section_name() ) + { + // We need to establish some stuff for EXCEPTION- function processing + + gg_assign(var_decl_exception_program_id, + gg_string_literal(current_function->our_unmangled_name)); + + if( strstr(current_function->current_section->label->name, "_implicit") + != current_function->current_section->label->name ) + { + gg_assign(var_decl_exception_section, + gg_string_literal(current_function->current_section->label->name)); + } + else + { + gg_assign(var_decl_exception_section, + gg_cast(build_pointer_type(CHAR_P),null_pointer_node)); + } + + if( strstr(current_function->current_paragraph->label->name, "_implicit") + != current_function->current_paragraph->label->name ) + { + gg_assign(var_decl_exception_paragraph, + gg_string_literal(current_function->current_paragraph->label->name)); + } + else + { + gg_assign(var_decl_exception_paragraph, + gg_cast(build_pointer_type(CHAR_P), null_pointer_node)); + } + + gg_assign(var_decl_exception_source_file, + gg_string_literal(current_filename.back().c_str())); + gg_assign(var_decl_exception_line_number, build_int_cst_type(INT, + CURRENT_LINE_NUMBER)); + gg_assign(var_decl_exception_statement, gg_string_literal(statement_name)); + } + } + +static +void +set_exception_environment( tree ecs, tree dcls ) + { + gg_call(VOID, + "__gg__set_exception_environment", + ecs ? gg_get_address_of(ecs) : null_pointer_node, + dcls ? gg_get_address_of(dcls) : null_pointer_node, + NULL_TREE); + } void -parser_statement_begin( const cbl_name_t statement_name, tree ecs, tree dcls ) +parser_statement_begin( const cbl_name_t statement_name, + tree ecs, + tree dcls ) { SHOW_PARSE { @@ -1014,7 +1148,7 @@ parser_statement_begin( const cbl_name_t statement_name, tree ecs, tree dcls ) { SHOW_PARSE_INDENT snprintf( ach, sizeof(ach), - "Sending ecs/dcls %p / %p", ecs, dcls); + "Sending ecs/dcls %p / %p", as_voidp(ecs), as_voidp(dcls)); SHOW_PARSE_TEXT(ach); } SHOW_PARSE_END @@ -1023,29 +1157,51 @@ parser_statement_begin( const cbl_name_t statement_name, tree ecs, tree dcls ) { TRACE1_HEADER char ach[64]; - snprintf(ach, sizeof(ach), " ecs/dcls %p / %p", ecs, dcls); + snprintf(ach, sizeof(ach), " ecs/dcls %p / %p", as_voidp(ecs), as_voidp(dcls)); TRACE1_TEXT_ABC("", ach, ""); TRACE1_END } - if( gg_get_current_line_number() == DEFAULT_LINE_NUMBER ) + gcc_assert( gg_trans_unit.function_stack.size() ); + + // In the cases where enabled_exceptions.size() is non-zero, or when + // there is a possibility of an EC-I-O exception because this is a file + // operation, we need to store the location information and do the exception + // overhead: + + static const std::set<std::string> file_ops = + { + "OPEN", + "CLOSE", + "READ", + "WRITE", + "DELETE", + "REWRITE", + "START", + }; + + // Performance note: By doing exception processing only when necessary + // the execution time of a program doing two-billion simple adds in an inner + // loop dropped from 3.8 seconds to 0.175 seconds. + + bool exception_processing = cdf_enabled_exceptions().size() ; + + if( !exception_processing ) { - // This code is intended to prevert GDB anomalies when the first line of a - // program is a PERFORM <proc> ... TEST AFTER ... UNTIL ... - gg_set_current_line_number(CURRENT_LINE_NUMBER-1); - gg_assign(var_decl_nop, build_int_cst_type(INT, 106)); + exception_processing = file_ops.find(statement_name) != file_ops.end(); } - store_location_stuff(statement_name); - gg_set_current_line_number(CURRENT_LINE_NUMBER); + // At this point, if any exception is enabled, we store the location stuff. + // Each file I-O routine calls store_location_stuff explicitly, because + // those exceptions can't be defeated. - gg_call(VOID, - "__gg__set_exception_environment", - ecs ? gg_get_address_of(ecs) : null_pointer_node, - dcls ? gg_get_address_of(dcls) : null_pointer_node, - NULL_TREE); - - gcc_assert( gg_trans_unit.function_stack.size() ); + if( exception_processing ) + { + store_location_stuff(statement_name); + set_exception_environment(ecs, dcls); + } + + sv_is_i_o = false; } static void @@ -1058,10 +1214,9 @@ initialize_variable_internal( cbl_refer_t refer, // gg_string_literal(refer.field->name), // NULL_TREE); cbl_field_t *parsed_var = refer.field; - - if( parsed_var->type == FldLiteralA ) + if( !parsed_var ) { - return; + cbl_internal_error("%s should not be null", "parsed_var"); } if( parsed_var->is_key_name() ) @@ -1077,7 +1232,7 @@ initialize_variable_internal( cbl_refer_t refer, return; } - if( parsed_var && parsed_var->type == FldBlob ) + if( parsed_var->type == FldBlob ) { return; } @@ -1195,15 +1350,13 @@ initialize_variable_internal( cbl_refer_t refer, SHOW_PARSE_END } - CHECK_FIELD(parsed_var); - // When initializing a variable, we have to ignore any DEPENDING ON clause // that might otherwise apply suppress_dest_depends = true; bool is_redefined = false; - cbl_field_t *family_tree = parsed_var; + const cbl_field_t *family_tree = parsed_var; while(family_tree) { if( symbol_redefines(family_tree) ) @@ -1224,7 +1377,7 @@ initialize_variable_internal( cbl_refer_t refer, if( parsed_var->data.initial ) { bool a_parent_initialized = false; - cbl_field_t *parent = parent_of(parsed_var); + const cbl_field_t *parent = parent_of(parsed_var); while( parent ) { if( parent->attr & has_value_e ) @@ -1254,7 +1407,7 @@ initialize_variable_internal( cbl_refer_t refer, flag_bits |= wsclear() ? DEFAULTBYTE_BIT + (*wsclear() & DEFAULT_BYTE_MASK) : 0; - flag_bits |= (refer.nsubscript << NSUBSCRIPT_SHIFT) & NSUBSCRIPT_MASK; + flag_bits |= (refer.nsubscript() << NSUBSCRIPT_SHIFT) & NSUBSCRIPT_MASK; flag_bits |= just_once ? JUST_ONCE_BIT : 0 ; suppress_dest_depends = false; // Set this to false so that refer_is_clean is valid @@ -1419,7 +1572,7 @@ initialize_variable_internal( cbl_refer_t refer, // } void -parser_initialize(cbl_refer_t refer, bool like_parser_symbol_add) +parser_initialize(const cbl_refer_t& refer, bool like_parser_symbol_add) { //gg_printf("parser_initialize %s\n", gg_string_literal(refer.field->name), NULL_TREE); if( like_parser_symbol_add ) @@ -1436,7 +1589,7 @@ parser_initialize(cbl_refer_t refer, bool like_parser_symbol_add) static void get_binary_value_from_float(tree value, - cbl_refer_t &dest, + const cbl_refer_t &dest, cbl_field_t *source, tree source_offset ) @@ -1516,42 +1669,29 @@ gg_default_qualification(struct cbl_field_t * /*var*/) // gg_attribute_bit_clear(var, refmod_e); } -static void -gg_get_depending_on_value(tree depending_on, cbl_field_t *current_sizer) +static +void +depending_on_value(tree depending_on, cbl_field_t *current_sizer) { // We have to deal with the possibility of a DEPENDING_ON variable, // and we have to apply array bounds whether or not there is a DEPENDING_ON // variable: - tree occurs_lower = gg_define_variable(LONG, "_lower"); - tree occurs_upper = gg_define_variable(LONG, "_upper"); - - gg_assign(occurs_lower, build_int_cst_type(LONG, current_sizer->occurs.bounds.lower)); - gg_assign(occurs_upper, build_int_cst_type(LONG, current_sizer->occurs.bounds.upper)); +// tree occurs_lower = gg_define_variable(LONG, "_lower"); +// tree occurs_upper = gg_define_variable(LONG, "_upper"); +// +// gg_assign(occurs_lower, build_int_cst_type(LONG, current_sizer->occurs.bounds.lower)); +// gg_assign(occurs_upper, build_int_cst_type(LONG, current_sizer->occurs.bounds.upper)); + gcc_assert(current_sizer); if( current_sizer->occurs.depending_on ) { - // Get the current value of the depending_on data-item: - tree value = gg_define_int128(); - get_binary_value( value, - NULL, - cbl_field_of(symbol_at(current_sizer->occurs.depending_on)), - size_t_zero_node); - gg_assign(depending_on, gg_cast(LONG, value)); - IF( depending_on, lt_op, occurs_lower ) - // depending_is can be no less than occurs_lower: - gg_assign(depending_on, occurs_lower ); - ELSE - ENDIF - IF( depending_on, gt_op, occurs_upper ) - // depending_is can be no greater than occurs_upper: - gg_assign(depending_on, occurs_upper ); - ELSE - ENDIF + get_depending_on_value_from_odo(depending_on, current_sizer); } else { - gg_assign(depending_on, occurs_upper); + gg_assign(depending_on, + build_int_cst_type(LONG, current_sizer->occurs.bounds.upper)); } } @@ -1654,7 +1794,7 @@ get_bytes_needed(cbl_field_t *field) } default: - cbl_internal_error("%s(): Knows not the variable type %s for %s", + cbl_internal_error("%s: Knows not the variable type %s for %s", __func__, cbl_field_type_str(field->type), field->name ); @@ -1687,16 +1827,12 @@ normal_normal_compare(bool debugging, NULL_TREE); } - bool needs_adjusting; if( !left_intermediate && !right_intermediate ) { // Yay! Both sides have fixed rdigit values. - // Flag needs_adjusting as false, because we are going to do it here: - needs_adjusting = false; int adjust = get_scaled_rdigits(left_side_ref->field) - get_scaled_rdigits(right_side_ref->field); - if( adjust > 0 ) { // We need to make right_side bigger to match the scale of left_side @@ -1711,6 +1847,7 @@ normal_normal_compare(bool debugging, else { // At least one side is right_intermediate + bool needs_adjusting; tree adjust; if( !left_intermediate && right_intermediate ) @@ -1947,8 +2084,8 @@ compare_binary_binary(tree return_int, { gg_printf("compare_binary_binary(): using int64\n", NULL_TREE); } - left_side = gg_define_variable( left_side_ref->field->attr & signable_e ? LONG : ULONG ); - right_side = gg_define_variable(right_side_ref->field->attr & signable_e ? LONG : ULONG ); + left_side = gg_define_variable( left_side_ref->field->has_attr(signable_e) ? LONG : ULONG ); + right_side = gg_define_variable(right_side_ref->field->has_attr(signable_e) ? LONG : ULONG ); } //tree dummy = gg_define_int(); @@ -2219,7 +2356,7 @@ cobol_compare( tree return_int, build_int_cst_type(INT, rightflags), integer_zero_node, NULL_TREE)); - compared = true; + // compared = true; // Commented out to quiet cppcheck } // gg_printf(" result is %d\n", return_int, NULL_TREE); @@ -2239,6 +2376,8 @@ move_tree( cbl_field_t *dest, SHOW_PARSE_END } + CHECK_FIELD(dest); + bool moved = true; tree source_length = gg_define_size_t(); @@ -2322,7 +2461,7 @@ move_tree( cbl_field_t *dest, psz_source, min_length, member(dest->var_decl_node, "picture"), - NULL); + NULL_TREE); break; } @@ -2343,10 +2482,10 @@ move_tree( cbl_field_t *dest, if( !moved ) { - dbgmsg("###### %10s in %s:%d\n", __func__, __FILE__, __LINE__ ); - cbl_internal_error( "I don't know how to MOVE an alphabetical string to %s(%s) \n", - cbl_field_type_str(dest->type), - dest->name + dbgmsg("%10s in %s:%d", __func__, __FILE__, __LINE__ ); + cbl_internal_error( "I don%'t know how to MOVE an alphabetical string to %s(%s)", + cbl_field_type_str(dest->type), + dest->name ); return; } @@ -2377,7 +2516,7 @@ get_string_from(cbl_field_t *field) gg_cast(CHAR_P, gg_malloc(build_int_cst_type(SIZE_T, field->data.capacity+1)))); - char *litstring = get_literal_string(field); + const char *litstring = get_literal_string(field); gg_memcpy(psz, gg_string_literal(litstring), build_int_cst_type(SIZE_T, field->data.capacity+1)); @@ -2412,7 +2551,7 @@ get_string_from(cbl_field_t *field) default: cbl_internal_error( - "%s(): field->type %s must be literal or alphanumeric", + "%s: %<field->type%> %s must be literal or alphanumeric", __func__, cbl_field_type_str(field->type)); break; } @@ -2425,12 +2564,12 @@ get_string_from(cbl_field_t *field) } static char * -combined_name(cbl_label_t *label) +combined_name(const cbl_label_t *label) { // This routine returns a pointer to a static, so make sure you use the result // before calling the routine again - char *para_name = nullptr; - char *sect_name = nullptr; + const char *para_name = nullptr; + const char *sect_name = nullptr; const char *program_name = current_function->our_unmangled_name; if( label->type == LblParagraph ) @@ -2440,7 +2579,7 @@ combined_name(cbl_label_t *label) if( label->parent ) { // It's possible for implicit - cbl_label_t *section_label = cbl_label_of(symbol_at(label->parent)); + const cbl_label_t *section_label = cbl_label_of(symbol_at(label->parent)); sect_name = section_label->name; } } @@ -2450,10 +2589,10 @@ combined_name(cbl_label_t *label) } static size_t retval_size = 256; - static char *retval= (char *)xmalloc(retval_size); + static char *retval= static_cast<char *>(xmalloc(retval_size)); char *paragraph = cobol_name_mangler(para_name); - char *section = cobol_name_mangler(sect_name); + char *section = cobol_name_mangler(sect_name); char *mangled_program_name = cobol_name_mangler(program_name); while( retval_size < (paragraph ? strlen(paragraph) : 0 ) @@ -2462,8 +2601,9 @@ combined_name(cbl_label_t *label) + 24 ) { retval_size *= 2; - retval = (char *)xrealloc(retval, retval_size); + retval = static_cast<char *>(xrealloc(retval, retval_size)); } + gcc_assert(retval); *retval = '\0'; char ach[24]; @@ -2510,8 +2650,9 @@ assembler_label(const char *label) { length = strlen(label) + strlen(local_text) + 1; free(build); - build = (char *)xmalloc(length); + build = static_cast<char *>(xmalloc(length)); } + gcc_assert(build); strcpy(build, label); strcat(build, local_text); @@ -2525,8 +2666,6 @@ section_label(struct cbl_proc_t *procedure) // With nested programs, you can have multiple program/section pairs with the // the same names; we use a deconflictor to avoid collisions - gg_set_current_line_number(CURRENT_LINE_NUMBER); - size_t deconflictor = symbol_label_id(procedure->label); cbl_label_t *label = procedure->label; @@ -2551,7 +2690,7 @@ section_label(struct cbl_proc_t *procedure) } assembler_label(psz2); free(psz2); - gg_assign(var_decl_nop, build_int_cst_type(INT, 108)); + insert_nop(108); } static void @@ -2566,8 +2705,6 @@ paragraph_label(struct cbl_proc_t *procedure) // are not referenced by the program. We provide a deconflictor to // separate such labels. - gg_set_current_line_number(CURRENT_LINE_NUMBER); - cbl_label_t *paragraph = procedure->label; cbl_label_t *section = nullptr; @@ -2589,6 +2726,9 @@ paragraph_label(struct cbl_proc_t *procedure) section_name ? section_name: "(null)" , current_function->our_unmangled_name ? current_function->our_unmangled_name: "" , (fmt_size_t)deconflictor ); + + // (0) is wrong, so back up one + gg_insert_into_assembler(psz1); SHOW_PARSE @@ -2605,7 +2745,25 @@ paragraph_label(struct cbl_proc_t *procedure) combined_name(procedure->label)); assembler_label(psz2); free(psz2); - gg_assign(var_decl_nop, build_int_cst_type(INT, 109)); + + // We are inserting a NOP after having created a label for the procedure. + // This means that when using GDC_COBOL to step into a procedure, the + // execution will stop there and show "123 para-name." at the stopped point. + // + // Note that because there is no user-specified executable code at that point + // the user can't set a working breakpoint with "break 123". But because + // GDB will pick up the psz2 text and set a breakpoint there (which is the + // location of the NOP) "break para-name" will actually stop and show line + // 123. + // + // This really only makes sense when you look at the assembly language. Keep + // in mind as you read it that issuing a "break 123" causes GDB to set a + // breakpoint at the first executable machine language code following the + // first ".loc 123" directive. + // + // Yes, trying to understand this causes headaches for many people who read + // this. Take an aspirin. + insert_nop(109); } static void @@ -2649,6 +2807,7 @@ pseudo_return_pop(cbl_proc_t *procedure) NULL_TREE); } + token_location_override(current_location_minus_one()); IF( var_decl_exit_address, eq_op, procedure->exit.addr ) { TRACE1 @@ -2658,11 +2817,13 @@ pseudo_return_pop(cbl_proc_t *procedure) // The top of the stack is us! // Pick up the return address from the pseudo_return stack: + token_location_override(current_location_minus_one()); gg_assign(current_function->void_star_temp, gg_call_expr( VOID_P, "__gg__pseudo_return_pop", NULL_TREE)); // And do the return: + token_location_override(current_location_minus_one()); gg_goto(current_function->void_star_temp); } ELSE @@ -2696,11 +2857,13 @@ leave_procedure(struct cbl_proc_t *procedure, bool /*section*/) // procedure->bottom.label); // Procedure can be null, for example at the beginning of a // new program, or after somebody else has cleared it out. + gg_append_statement(procedure->exit.label); char *psz; psz = xasprintf("_procret." HOST_SIZE_T_PRINT_DEC ":", (fmt_size_t)symbol_label_id(procedure->label)); + token_location_override(current_location_minus_one()); gg_insert_into_assembler(psz); free(psz); pseudo_return_pop(procedure); @@ -2813,7 +2976,9 @@ find_procedure(cbl_label_t *label) static int counter=1; // This is a new section or paragraph; we need to create its values: - retval = (struct cbl_proc_t *)xmalloc(sizeof(struct cbl_proc_t)); + retval = static_cast<struct cbl_proc_t *> + (xmalloc(sizeof(struct cbl_proc_t))); + gcc_assert(retval); retval->label = label; gg_create_goto_pair(&retval->top.go_to, @@ -2869,6 +3034,8 @@ parser_enter_section(cbl_label_t *label) { SHOW_PARSE_HEADER SHOW_PARSE_LABEL(" ", label) + SHOW_PARSE_INDENT + linemap_dump_location( line_table, current_token_location(), stderr ); SHOW_PARSE_END } @@ -2876,8 +3043,7 @@ parser_enter_section(cbl_label_t *label) // This NOP is needed to give GDB a line number for the entry point of // paragraphs - gg_set_current_line_number(CURRENT_LINE_NUMBER); - gg_assign(var_decl_nop, build_int_cst_type(INT, 101)); + insert_nop(101); struct cbl_proc_t *procedure = find_procedure(label); gg_append_statement(procedure->top.label); @@ -2904,6 +3070,8 @@ parser_enter_paragraph(cbl_label_t *label) { SHOW_PARSE_HEADER SHOW_PARSE_LABEL(" ", label) + SHOW_PARSE_INDENT + linemap_dump_location( line_table, current_token_location(), stderr ); SHOW_PARSE_END } @@ -3119,16 +3287,20 @@ parser_goto( cbl_refer_t value_ref, size_t narg, cbl_label_t * const labels[] ) void parser_perform(cbl_label_t *label, bool suppress_nexting) { - label->used = yylineno; Analyze(); SHOW_PARSE { SHOW_PARSE_HEADER SHOW_PARSE_LABEL(" ", label) char ach[32]; - sprintf(ach, " label is at %p", (void*)label); + sprintf(ach, " label is at %p", static_cast<void*>(label)); SHOW_PARSE_TEXT(ach) - sprintf(ach, " label->proc is %p", (void*)label->structs.proc); + if( label ) + { + sprintf(ach, + " label->proc is %p", + static_cast<void*>(label->structs.proc)); + } SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } @@ -3141,6 +3313,7 @@ parser_perform(cbl_label_t *label, bool suppress_nexting) } CHECK_LABEL(label); + label->used = yylineno; struct cbl_proc_t *procedure = find_procedure(label); @@ -3169,17 +3342,17 @@ parser_perform(cbl_label_t *label, bool suppress_nexting) // pairs were created, the locations of the goto instruction and the label // were not known. - char *para_name = nullptr; - char *sect_name = nullptr; + const char *para_name = nullptr; + const char *sect_name = nullptr; const char *program_name = current_function->our_unmangled_name; size_t deconflictor = symbol_label_id(label); char ach[256]; if( label->type == LblParagraph ) { - cbl_label_t *section_label = cbl_label_of(symbol_at(label->parent)); + const cbl_label_t *sec_label = cbl_label_of(symbol_at(label->parent)); para_name = label->name; - sect_name = section_label->name; + sect_name = sec_label->name; sprintf(ach, "%s PERFORM %s of %s of %s (" HOST_SIZE_T_PRINT_DEC ")", ASM_COMMENT_START, @@ -3239,9 +3412,9 @@ parser_perform_times( cbl_label_t *proc_1, cbl_refer_t count ) SHOW_PARSE_REF(" ", count) SHOW_PARSE_TEXT(" TIMES") char ach[32]; - sprintf(ach, " proc_1 is at %p", (void*)proc_1); + sprintf(ach, " proc_1 is at %p", static_cast<void*>(proc_1)); SHOW_PARSE_TEXT(ach) - sprintf(ach, " proc_1->proc is %p", (void*)proc_1->structs.proc); + sprintf(ach, " proc_1->proc is %p", static_cast<void*>(proc_1->structs.proc)); SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } @@ -3278,6 +3451,7 @@ parser_perform_times( cbl_label_t *proc_1, cbl_refer_t count ) sprintf(ach, "_procretb." HOST_SIZE_T_PRINT_DEC ":", (fmt_size_t)our_pseudo_label); + token_location_override(current_location_minus_one()); gg_insert_into_assembler(ach); } @@ -3292,17 +3466,22 @@ internal_perform_through( cbl_label_t *proc_1, SHOW_PARSE_HEADER SHOW_PARSE_LABEL(" ", proc_1); char ach[32]; - sprintf(ach, " proc_1 is at %p", (void*)proc_1); + sprintf(ach, " proc_1 is at %p", static_cast<void*>(proc_1)); SHOW_PARSE_TEXT(ach) - sprintf(ach, " proc_1->proc is %p", (void*)proc_1->structs.proc); + if( proc_1 ) + { + sprintf(ach, + " proc_1->proc is %p", + static_cast<void*>(proc_1->structs.proc)); + } SHOW_PARSE_TEXT(ach) if( proc_2 ) { SHOW_PARSE_INDENT - SHOW_PARSE_LABEL("", proc_2); - sprintf(ach, " proc_2 is at %p", (void*)proc_2); + SHOW_PARSE_LABEL_OK("", proc_2); + sprintf(ach, " proc_2 is at %p", static_cast<void*>(proc_2)); SHOW_PARSE_TEXT(ach) - sprintf(ach, " proc_2->proc is %p", (void*)proc_2->structs.proc); + sprintf(ach, " proc_2->proc is %p", static_cast<void*>(proc_2->structs.proc)); SHOW_PARSE_TEXT(ach) } SHOW_PARSE_END @@ -3315,14 +3494,12 @@ internal_perform_through( cbl_label_t *proc_1, CHECK_LABEL(proc_1); - if(!proc_2) + if( !proc_2 ) { parser_perform(proc_1, suppress_nexting); return; } - CHECK_LABEL(proc_2); - struct cbl_proc_t *proc1 = find_procedure(proc_1); struct cbl_proc_t *proc2 = find_procedure(proc_2); @@ -3347,7 +3524,7 @@ internal_perform_through( cbl_label_t *proc_1, pseudo_return_push(proc2, return_addr); // Create the code that will launch the first procedure - gg_insert_into_assembler("%s PERFORM %s THROUGH %s", + gg_insert_into_assemblerf("%s PERFORM %s THROUGH %s", ASM_COMMENT_START, proc_1->name, proc_2->name); if( !suppress_nexting ) @@ -3377,17 +3554,22 @@ internal_perform_through_times( cbl_label_t *proc_1, SHOW_PARSE_HEADER SHOW_PARSE_LABEL(" ", proc_1); char ach[32]; - sprintf(ach, " proc_1 is at %p", (void*)proc_1); + sprintf(ach, " proc_1 is at %p", static_cast<void*>(proc_1)); SHOW_PARSE_TEXT(ach) - sprintf(ach, " proc_1->proc is %p", (void*)proc_1->structs.proc); + if( proc_1 ) + { + sprintf(ach, + " proc_1->proc is %p", + static_cast<void*>(proc_1->structs.proc)); + } SHOW_PARSE_TEXT(ach) if( proc_2 ) { SHOW_PARSE_INDENT - SHOW_PARSE_LABEL("", proc_2); - sprintf(ach, " proc_2 is at %p", (void*)proc_2); + SHOW_PARSE_LABEL_OK("", proc_2); + sprintf(ach, " proc_2 is at %p", static_cast<void*>(proc_2)); SHOW_PARSE_TEXT(ach) - sprintf(ach, " proc_2->proc is %p", (void*)proc_2->structs.proc); + sprintf(ach, " proc_2->proc is %p", static_cast<void*>(proc_2->structs.proc)); SHOW_PARSE_TEXT(ach) } SHOW_PARSE_REF(" ", count); @@ -3423,6 +3605,7 @@ internal_perform_through_times( cbl_label_t *proc_1, sprintf(ach, "_procretb." HOST_SIZE_T_PRINT_DEC ":", (fmt_size_t)our_pseudo_label); + token_location_override(current_location_minus_one()); gg_insert_into_assembler( ach ); } @@ -3497,8 +3680,6 @@ parser_first_statement( int lineno ) } } -#define linemap_add(...) - void parser_enter_file(const char *filename) { @@ -3530,9 +3711,6 @@ parser_enter_file(const char *filename) } } - // Let the linemap routine know we are working on a new file: - linemap_add(line_table, LC_ENTER, 0, filename, 1); - if( file_level == 0 ) { // Build a translation_unit_decl: @@ -3605,16 +3783,38 @@ parser_leave_file() { SHOW_PARSE_HEADER char ach[256]; - sprintf(ach, "leaving level:%d %s", file_level, current_filename.back().c_str()); + sprintf(ach, + "leaving level:%d %s", + file_level, + current_filename.back().c_str()); SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } - if( file_level > 0) - { - linemap_add(line_table, LC_LEAVE, false, NULL, 0); - } file_level -= 1; current_filename.pop_back(); + + if( file_level == 0 ) + { + // We are leaving the top-level file, which means this compilation is + // done, done, done. + + // There is, however, one thing left to do. If the command line says + // that this module needs a main entry point, then this is where + // we create a main() function. We build it at the end, so that all of + // the .loc directives associated with it appear at the end of the + // source code. We used to create the main() entry point at the beginning, + // but that created confusion for GDB when trying to debug the generated + // executable. + if( main_entry_point ) + { + next_program_is_main = false; + build_main_that_calls_something(main_entry_point); + free(main_entry_point); + main_entry_point = NULL; + } + + gg_leaving_the_source_code_file(); + } } void @@ -3629,15 +3829,16 @@ enter_program_common(const char *funcname, const char *funcname_) // have no parameters. We'll chain the parameters on in parser_division(), // when we process PROCEDURE DIVISION USING... - gg_define_function_with_no_parameters( COBOL_FUNCTION_RETURN_TYPE, - funcname, - funcname_); + gg_define_function(COBOL_FUNCTION_RETURN_TYPE, + funcname, + funcname_, + NULL_TREE); current_function->first_time_through = - gg_define_variable(INT, - "_first_time_through", - vs_static, - integer_one_node); + gg_define_variable(INT, + "_first_time_through", + vs_static, + integer_one_node); gg_create_goto_pair(¤t_function->skip_init_goto, ¤t_function->skip_init_label); @@ -3662,8 +3863,6 @@ enter_program_common(const char *funcname, const char *funcname_) current_function->current_section = NULL; current_function->current_paragraph = NULL; - current_function->is_truly_nested = false; - // Text conversion must be initialized before the code generated by // parser_symbol_add runs. @@ -3723,20 +3922,22 @@ parser_enter_program( const char *funcname_, // The first thing we have to do is mangle this name. This is safe even // though the end result will be mangled again, because the mangler doesn't // change a mangled name. + char *mangled_name = cobol_name_mangler(funcname_); size_t parent_index = current_program_index(); - char funcname[128]; + char *funcname; if( parent_index ) { // This is a nested function. Tack on the parent_index to the end of it. - sprintf(funcname, "%s." HOST_SIZE_T_PRINT_DEC, mangled_name, - (fmt_size_t)parent_index); + funcname = xasprintf( "%s." HOST_SIZE_T_PRINT_DEC, + mangled_name, + (fmt_size_t)parent_index); } else { // This is a top-level function; just use the straight mangled name - strcpy(funcname, mangled_name); + funcname = xstrdup(mangled_name); } free(mangled_name); @@ -3750,28 +3951,25 @@ parser_enter_program( const char *funcname_, if( !is_function && !parent_index ) { - // This is a top_level program, and not a function + // This is a top_level program-id, and not a function if( next_program_is_main ) { + // This is the first top-level program-id. next_program_is_main = false; - if(main_entry_point) - { - build_main_that_calls_something(main_entry_point); - free(main_entry_point); - main_entry_point = NULL; - } - else + if( !main_entry_point ) { - build_main_that_calls_something(funcname); + // Because no explicit main_entry_point was specified, this program-id, + // the first in the file, becomes the target of the main() function + // that will be created at parser_leave_file time. + main_entry_point = xstrdup(funcname); + + char *psz = cobol_name_mangler(main_entry_point); + strncpy(ach_cobol_entry_point, psz, sizeof(ach_cobol_entry_point)-1); + free(psz); } } } - // Call this after build_main_that_calls_something, because it manipulates - // the current line number to DEFAULT_LINE_NUMBER. We have to manipulate it - // back afterward. - gg_set_current_line_number(CURRENT_LINE_NUMBER); - if( strcmp(funcname_, "main") == 0 && this_module_has_main ) { // setting 'retval' to 1 let's the caller know that we are being told @@ -3802,6 +4000,8 @@ parser_enter_program( const char *funcname_, TRACE1_TEXT("\"") TRACE1_END } + + free(funcname); } void @@ -3959,6 +4159,8 @@ psa_FldLiteralN(struct cbl_field_t *field ) // We are constructing a completely static constant structure, based on the // text string in .initial + CHECK_FIELD(field); + FIXED_WIDE_INT(128) value = 0; do @@ -3997,7 +4199,7 @@ psa_FldLiteralN(struct cbl_field_t *field ) int rdigit_delta = 0; int exponent = 0; - char *exp = strchr(p, 'E'); + const char *exp = strchr(p, 'E'); if( !exp ) { exp = strchr(p, 'e'); @@ -4151,6 +4353,8 @@ psa_FldBlob(struct cbl_field_t *var ) SHOW_PARSE_END } + CHECK_FIELD(var); + // We are constructing a completely static constant structure. We know the // capacity. We'll create it from the data.initial. The var_decl_node will // be a pointer to the data @@ -4188,67 +4392,182 @@ psa_FldBlob(struct cbl_field_t *var ) } void -parser_accept( struct cbl_refer_t refer, - enum special_name_t special_e ) +parser_accept(const struct cbl_refer_t &tgt, + special_name_t special_e, + cbl_label_t *error, + cbl_label_t *not_error ) { - Analyze(); SHOW_PARSE { SHOW_PARSE_HEADER - SHOW_PARSE_REF(" ", refer); + if( error ) + { + SHOW_PARSE_LABEL(" error ", error) + } + if( not_error ) + { + SHOW_PARSE_LABEL(" not_error ", not_error) + } SHOW_PARSE_END } - TRACE1 - { - TRACE1_HEADER - TRACE1_END - } - - /* - enum special_name_t - { - SYSIN_e, - SYSIPT_e, - SYSOUT_e, - SYSLIST_e, - SYSLST_e, - SYSPUNCH_e, - SYSPCH_e, - CONSOLE_e, - C01_e, C02_e, C03_e, C04_e, C05_e, C06_e, - C07_e, C08_e, C09_e, C10_e, C11_e, C12_e, - CSP_e, - S01_e, S02_e, S03_e, S04_e, S05_e, - AFP_5A_e, - }; - */ // The ISO spec describes the valid special names for ACCEPT as implementation // dependent. We are following IBM's lead. tree environment = build_int_cst_type(INT, special_e); - switch( special_e ) + const char *function_to_call = NULL; + + switch(special_e) { + case STDIN_e: case CONSOLE_e: case SYSIPT_e: case SYSIN_e: - break; - default: - dbgmsg("%s(): We don't know what to do with special_name_t %d,", __func__, special_e); - dbgmsg("%s(): so we are ignoring it.", __func__); - yywarn("unrecognized SPECIAL NAME ignored"); + // This is ordinary input from from the stdin: + gg_call(VOID, + "__gg__accept", + environment, + gg_get_address_of(tgt.field->var_decl_node), + refer_offset(tgt), + refer_size_dest(tgt), + NULL_TREE); return; break; - } - gg_call(VOID, - "__gg__accept", - environment, - gg_get_address_of(refer.field->var_decl_node), - refer_offset(refer), - refer_size_dest(refer), - NULL_TREE); + case C01_e: + case C02_e: + case C03_e: + case C04_e: + case C05_e: + case C06_e: + case C07_e: + case C08_e: + case C09_e: + case C10_e: + case C11_e: + case C12_e: + case CSP_e: + case S01_e: + case S02_e: + case S03_e: + case S04_e: + case S05_e: + case AFP_5A_e: + case STDOUT_e: + case SYSOUT_e: + case SYSLIST_e: + case SYSLST_e: + case STDERR_e: + case SYSPUNCH_e: + case SYSPCH_e: + case SYSERR_e: + cbl_internal_error("Not valid for ACCEPT statement."); + break; + + case ARG_NUM_e: + // This ACCEPT statement wants the number of argv values: + gg_call(VOID, + "__gg__get_argc", + gg_get_address_of(tgt.field->var_decl_node), + refer_offset(tgt), + refer_size_source(tgt), + NULL_TREE); + return; + break; + + case ENV_NAME_e: + // This fetches the environment name set by DISPLAY... UPON ENV_NAME_e + gg_call(VOID, + "__gg__get_env_name", + gg_get_address_of(tgt.field->var_decl_node), + refer_offset(tgt), + refer_size_source(tgt), + NULL_TREE); + return; + break; + + case ENV_VALUE_e: + // This fetches the environment value associated with the previously + // esablished name + function_to_call = "__gg__get_env_value"; + break; + + case ARG_VALUE_e: + // We are fetching the variable whose index was established by a prior + // DISPLAY UPON ARGUMENT-NUMBER. After the fetch, the value will be + // incremented by one. + function_to_call = "__gg__accept_arg_value"; + break; + } + if( function_to_call ) + { + tree erf = gg_define_int(); + gg_assign(erf, + gg_call_expr( INT, + function_to_call, + gg_get_address_of(tgt.field->var_decl_node), + refer_offset(tgt), + refer_size_dest(tgt), + NULL_TREE)); + if( error ) + { + // There is an ON EXCEPTION phrase: + IF( erf, ne_op, integer_zero_node ) + { + SHOW_PARSE + { + SHOW_PARSE_INDENT + SHOW_PARSE_TEXT("Laying down GOTO error->INTO for_argv") + SHOW_PARSE_LABEL_OK(" ", error) + } + gg_append_statement( error->structs.arith_error->into.go_to ); + } + ELSE + { + } + ENDIF + } + if( not_error ) + { + // There is an NOT ON EXCEPTION phrase: + IF( erf, eq_op, integer_zero_node ) + { + SHOW_PARSE + { + SHOW_PARSE_INDENT + SHOW_PARSE_TEXT("Laying down GOTO not_error->INTO for_argv") + SHOW_PARSE_LABEL_OK(" ", not_error) + } + gg_append_statement( not_error->structs.arith_error->into.go_to ); + } + ELSE + { + } + ENDIF + } + if( error ) + { + SHOW_PARSE + { + SHOW_PARSE_INDENT + SHOW_PARSE_TEXT("Laying down LABEL error->bottom") + SHOW_PARSE_LABEL_OK(" ", error) + } + gg_append_statement( error->structs.arith_error->bottom.label ); + } + if( not_error ) + { + SHOW_PARSE + { + SHOW_PARSE_INDENT + SHOW_PARSE_TEXT("Laying down LABEL not_error->bottom") + SHOW_PARSE_LABEL_OK(" ", not_error) + SHOW_PARSE_END + } + gg_append_statement( not_error->structs.arith_error->bottom.label ); + } + } } // TODO: update documentation. @@ -4260,7 +4579,6 @@ parser_accept_exception( cbl_label_t *accept_label ) // We are entering either SIZE ERROR or NOT SIZE ERROR code RETURN_IF_PARSE_ONLY; - set_up_on_exception_label(accept_label); SHOW_PARSE { @@ -4273,6 +4591,9 @@ parser_accept_exception( cbl_label_t *accept_label ) SHOW_PARSE_END } + CHECK_LABEL(accept_label); + set_up_on_exception_label(accept_label); + // Jump over the [NOT] ON EXCEPTION code that is about to be laid down gg_append_statement( accept_label->structs.arith_error->over.go_to ); // Create the label that allows the following code to be executed at @@ -4299,6 +4620,8 @@ parser_accept_exception_end( cbl_label_t *accept_label ) SHOW_PARSE_END } + CHECK_LABEL(accept_label); + // Jump to the end of the arithmetic code: gg_append_statement( accept_label->structs.arith_error->bottom.go_to ); // Lay down the label that allows the ERROR/NOT ERROR instructions @@ -4308,8 +4631,8 @@ parser_accept_exception_end( cbl_label_t *accept_label ) } void -parser_accept_command_line( cbl_refer_t tgt, - cbl_refer_t source, +parser_accept_command_line( const cbl_refer_t &tgt, + const cbl_refer_t &source, cbl_label_t *error, cbl_label_t *not_error ) { @@ -4349,7 +4672,7 @@ parser_accept_command_line( cbl_refer_t tgt, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("Laying down GOTO error->INTO for_command_line") - SHOW_PARSE_LABEL(" ", error) + SHOW_PARSE_LABEL_OK(" ", error) } gg_append_statement( error->structs.arith_error->into.go_to ); } @@ -4367,7 +4690,7 @@ parser_accept_command_line( cbl_refer_t tgt, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("Laying down GOTO not_error->INTO for command_line") - SHOW_PARSE_LABEL(" ", not_error) + SHOW_PARSE_LABEL_OK(" ", not_error) } gg_append_statement( not_error->structs.arith_error->into.go_to ); } @@ -4399,7 +4722,7 @@ parser_accept_command_line( cbl_refer_t tgt, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("Laying down GOTO error->INTO for_argv") - SHOW_PARSE_LABEL(" ", error) + SHOW_PARSE_LABEL_OK(" ", error) } gg_append_statement( error->structs.arith_error->into.go_to ); } @@ -4417,7 +4740,7 @@ parser_accept_command_line( cbl_refer_t tgt, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("Laying down GOTO not_error->INTO for_argv") - SHOW_PARSE_LABEL(" ", not_error) + SHOW_PARSE_LABEL_OK(" ", not_error) } gg_append_statement( not_error->structs.arith_error->into.go_to ); } @@ -4433,7 +4756,7 @@ parser_accept_command_line( cbl_refer_t tgt, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("Laying down LABEL error->bottom") - SHOW_PARSE_LABEL(" ", error) + SHOW_PARSE_LABEL_OK(" ", error) } gg_append_statement( error->structs.arith_error->bottom.label ); } @@ -4443,7 +4766,7 @@ parser_accept_command_line( cbl_refer_t tgt, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("Laying down LABEL not_error->bottom") - SHOW_PARSE_LABEL(" ", not_error) + SHOW_PARSE_LABEL_OK(" ", not_error) SHOW_PARSE_END } gg_append_statement( not_error->structs.arith_error->bottom.label ); @@ -4451,7 +4774,7 @@ parser_accept_command_line( cbl_refer_t tgt, } void -parser_accept_command_line_count( cbl_refer_t tgt ) +parser_accept_command_line_count( const cbl_refer_t &tgt ) { Analyze(); SHOW_PARSE @@ -4473,10 +4796,10 @@ parser_accept_command_line_count( cbl_refer_t tgt ) } void -parser_accept_envar(struct cbl_refer_t tgt, - struct cbl_refer_t envar, - cbl_label_t *error, - cbl_label_t *not_error ) +parser_accept_envar(const struct cbl_refer_t &tgt, + const struct cbl_refer_t &envar, + cbl_label_t *error, + cbl_label_t *not_error ) { Analyze(); @@ -4541,7 +4864,7 @@ parser_accept_envar(struct cbl_refer_t tgt, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("Laying down LABEL error->bottom") - SHOW_PARSE_LABEL(" ", error) + SHOW_PARSE_LABEL_OK(" ", error) } gg_append_statement( error->structs.arith_error->bottom.label ); } @@ -4551,7 +4874,7 @@ parser_accept_envar(struct cbl_refer_t tgt, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("Laying down LABEL not_error->bottom") - SHOW_PARSE_LABEL(" ", not_error) + SHOW_PARSE_LABEL_OK(" ", not_error) SHOW_PARSE_END } gg_append_statement( not_error->structs.arith_error->bottom.label ); @@ -4559,7 +4882,8 @@ parser_accept_envar(struct cbl_refer_t tgt, } void -parser_set_envar( struct cbl_refer_t name, struct cbl_refer_t value ) +parser_set_envar( const struct cbl_refer_t &name, + const struct cbl_refer_t &value ) { Analyze(); SHOW_PARSE @@ -4961,7 +5285,6 @@ parser_display_internal(tree file_descriptor, build_int_cst_type(SIZE_T, refer.field->data.capacity), advance ? integer_one_node : integer_zero_node, NULL_TREE ); - cursor_at_sol = advance; } else if( refer.field->type == FldLiteralN ) { @@ -4999,50 +5322,50 @@ parser_display_internal(tree file_descriptor, *p = 'E'; if( exp < 0 && exp >= -9 ) { - p[1] = '-'; - p[2] = '0'; - p[3] = '0' - exp; - p[4] = '\0'; + p[1] = '-'; + p[2] = '0'; + p[3] = '0' - exp; + p[4] = '\0'; } else if( exp >= 0 && exp <= 9 ) { - p[1] = '+'; - p[2] = '0'; - p[3] = '0' + exp; - p[4] = '\0'; + p[1] = '+'; + p[2] = '0'; + p[3] = '0' + exp; + p[4] = '\0'; } } else if (exp == 0) { - p[-1] = '\0'; + p[-1] = '\0'; } else if (exp < 0) { - p[-1] = '\0'; - char *q = strchr (ach, '.'); - char dig = q[-1]; - q[-1] = '\0'; - char tem[132]; - snprintf (tem, 132, "%s0.%0*u%c%s", ach, -exp - 1, 0, dig, q + 1); - strcpy (ach, tem); + p[-1] = '\0'; + char *q = strchr (ach, '.'); + char dig = q[-1]; + q[-1] = '\0'; + char tem[132]; + snprintf (tem, 132, "%s0.%0*d%c%s", ach, -exp - 1, 0, dig, q + 1); + strcpy (ach, tem); } - else if (exp > 0) + else // if (exp > 0) { - p[-1] = '\0'; - char *q = strchr (ach, '.'); - for (int i = 0; i != exp; ++i) - q[i] = q[i + 1]; - q[exp] = '.'; + p[-1] = '\0'; + char *q = strchr (ach, '.'); + for (int i = 0; i != exp; ++i) + q[i] = q[i + 1]; + q[exp] = '.'; } __gg__remove_trailing_zeroes(ach); } if( symbol_decimal_point() == ',' ) { - char *p = strchr(ach, '.' ); - if( p ) + char *pdot = strchr(ach, '.' ); + if( pdot ) { - *p = symbol_decimal_point(); + *pdot = symbol_decimal_point(); } } @@ -5099,22 +5422,29 @@ parser_display_field(cbl_field_t *field) DISPLAY_NO_ADVANCE); } -/* - * The first parameter to parser_display is the "device" upon which to display - * the data. Besides normal devices, these may include elements that define the - * Unix command line and environment: - * 1. ARG_NUM_e, the ARGUMENT-NUMBER - * 2. ARG_VALUE_e, the ARGUMENT-VALUE - * 3. ENV_NAME_e, the ENVIRONMENT-NAME - * 4. ENV_VALUE_e, the ENVIRONMENT-VALUE - * that need special care and feeding. - */ void parser_display( const struct cbl_special_name_t *upon, - struct cbl_refer_t refs[], - size_t n, - bool advance ) + const std::vector<cbl_refer_t> &refs, + bool advance, + const cbl_label_t *not_error, + const cbl_label_t *error ) { + const size_t n = refs.size(); + /* + * The first parameter to parser_display is the "device" upon which to display + * the data. Besides normal devices, these may include elements that define the + * Unix command line and environment: + * 1. ARG_NUM_e, the ARGUMENT-NUMBER + * 2. ARG_VALUE_e, the ARGUMENT-VALUE + * 3. ENV_NAME_e, the ENVIRONMENT-NAME + * 4. ENV_VALUE_e, the ENVIRONMENT-VALUE + * that need special care and feeding. + */ + + // At the present time, I am not sure what not_error and error are for + gcc_assert(!not_error); + gcc_assert(!error); + Analyze(); SHOW_PARSE { @@ -5123,7 +5453,7 @@ parser_display( const struct cbl_special_name_t *upon, for(size_t i=0; i<n; i++) { SHOW_PARSE_INDENT - SHOW_PARSE_REF("", refs[i]); + SHOW_PARSE_REF("", refs.at(i)); } if( advance ) { @@ -5155,33 +5485,100 @@ parser_display( const struct cbl_special_name_t *upon, { switch(upon->id) { + // See table 5 in the IBM Cobol For Linux x86 1.2 document. + + case STDIN_e: + case SYSIN_e: + case SYSIPT_e: + cbl_internal_error("Attempting to send to an input device."); + break; + + case C01_e: + case C02_e: + case C03_e: + case C04_e: + case C05_e: + case C06_e: + case C07_e: + case C08_e: + case C09_e: + case C10_e: + case C11_e: + case C12_e: + case CSP_e: + case S01_e: + case S02_e: + case S03_e: + case S04_e: + case S05_e: + case AFP_5A_e: + case ARG_VALUE_e: + cbl_internal_error("Not valid for DISPLAY statement."); + break; + case STDOUT_e: - case SYSOUT_e: - case SYSLIST_e: - case SYSLST_e: case CONSOLE_e: + // These are inarguably stdout gg_assign(file_descriptor, integer_one_node); break; case STDERR_e: + case SYSERR_e: + // These are inarguably stderr + gg_assign(file_descriptor, integer_two_node); + break; + + case SYSOUT_e: + case SYSLIST_e: + case SYSLST_e: case SYSPUNCH_e: case SYSPCH_e: - gg_assign(file_descriptor, integer_two_node); + // In the 21st century, when there are no longer valid assumptions to + // be made about the existence of line printers, and where things + // formerly-ubiquitous card punches no longer exist, there is a need + // for the possibility of assigning these "devices" to externally- + // determined Unix gadgetry in /dev: + gg_assign(file_descriptor, + gg_call_expr( INT, + "__gg__get_file_descriptor", + gg_string_literal(upon->os_filename), + NULL_TREE)); + needs_closing = true; break; - default: - if( upon->os_filename[0] ) - { - tree topen = gg_open( gg_string_literal(upon->os_filename), - build_int_cst_type(INT, O_APPEND|O_WRONLY)); - gg_assign(file_descriptor, topen); - needs_closing = true; - } - else - { - fprintf(stderr, "We don't know what to do in parser_display\n"); - gcc_unreachable(); - } + case ARG_NUM_e: + // Set the index number for a subsequent ACCEPT FROM ARG_VALUE_e + gg_call(VOID, + "__gg__set_arg_num", + gg_get_address_of(refs[0].field->var_decl_node), + refer_offset(refs[0]), + refer_size_source(refs[0]), + NULL_TREE); + return; + break; + + case ENV_NAME_e: + // Establish the name of an environment variable for later use with + // in either DISPLAY UPON or ACCEPT FROM + gg_call(VOID, + "__gg__set_env_name", + gg_get_address_of(refs[0].field->var_decl_node), + refer_offset(refs[0]), + refer_size_source(refs[0]), + NULL_TREE); + return; + break; + + case ENV_VALUE_e: + // Set the contents of the environment variable named with ENV_NAME_e + gg_call(VOID, + "__gg__set_env_value", + gg_get_address_of(refs[0].field->var_decl_node), + refer_offset(refs[0]), + refer_size_source(refs[0]), + NULL_TREE); + return; + break; } } else @@ -5196,17 +5593,114 @@ parser_display( const struct cbl_special_name_t *upon, } CHECK_FIELD(refs[n-1].field); parser_display_internal(file_descriptor, refs[n-1], advance ? DISPLAY_ADVANCE : DISPLAY_NO_ADVANCE); - if( needs_closing ) { - tree tclose = gg_close(file_descriptor); - // We are ignoring the close() return value - gg_append_statement(tclose); + gg_close(file_descriptor); } cursor_at_sol = advance; } +static +bool // Returns false for literals; true for named variables +get_exhibit_name(tree file_descriptor, const cbl_refer_t &arg) + { + bool retval; + if( is_literal(arg.field) ) + { + // If something is a literal, we just display the literal value + parser_display_internal(file_descriptor, + arg, + DISPLAY_NO_ADVANCE); + retval = false; + } + else + { + // It's not a literal, so we show its name, and the names or literal + // values) of any qualifier subscripts or refmods + gg_write( file_descriptor, + gg_string_literal(arg.field->name), + build_int_cst_type(SIZE_T, strlen(arg.field->name)) ); + + if( arg.subscripts.size() ) + { + // This refer has subscripts: + gg_write( file_descriptor, + gg_string_literal("("), + integer_one_node ); + for(size_t i=0; i<arg.subscripts.size(); i++) + { + if( i > 0 ) + { + gg_write( file_descriptor, + gg_string_literal(","), + integer_one_node ); + } + get_exhibit_name(file_descriptor, arg.subscripts[i]); + } + gg_write( file_descriptor, + gg_string_literal(")"), + integer_one_node ); + } + if( arg.refmod.from || arg.refmod.len ) + { + gg_write( file_descriptor, + gg_string_literal("("), + integer_one_node ); + if( arg.refmod.from ) + { + get_exhibit_name(file_descriptor, *(arg.refmod.from)); + } + gg_write( file_descriptor, + gg_string_literal(":"), + integer_one_node ); + if( arg.refmod.len ) + { + get_exhibit_name(file_descriptor, *(arg.refmod.len)); + } + gg_write( file_descriptor, + gg_string_literal(")"), + integer_one_node ); + } + retval = true; + } + return retval; + } + +void +parser_exhibit( bool /*changed*/, bool /*named*/, + const std::vector<cbl_refer_t> &args ) + { + tree file_descriptor = gg_define_int(); + gg_assign(file_descriptor, integer_one_node); // stdout is file descriptor 1. + + for(size_t i=0; i<args.size(); i++) + { + CHECK_FIELD(args[i].field); + if(i > 0) + { + // When there more than one argument, the second through Nth get a space + // in front of them. + gg_write( file_descriptor, + gg_string_literal(" "), + integer_one_node); + } + if( get_exhibit_name(file_descriptor, args[i]) ) + { + gg_write( file_descriptor, + gg_string_literal("="), + integer_one_node); + parser_display_internal(file_descriptor, + args[i], + DISPLAY_NO_ADVANCE); + } + } + gg_write( file_descriptor, + gg_string_literal("\n"), + integer_one_node); + cursor_at_sol = true; + } + static tree get_literalN_value(cbl_field_t *var) { @@ -5479,12 +5973,12 @@ parser_assign( size_t nC, cbl_num_result_t *C, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT(" Laying down on_error GOTO into") - SHOW_PARSE_LABEL(" ", on_error) + SHOW_PARSE_LABEL_OK(" ", on_error) } IF( gg_bitwise_or(error_flag, compute_error->structs.compute_error->compute_error_code), - ne_op, - integer_zero_node ) + ne_op, + integer_zero_node ) { gg_append_statement( on_error->structs.arith_error->into.go_to ); } @@ -5510,7 +6004,7 @@ parser_assign( size_t nC, cbl_num_result_t *C, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT(" Laying down not_error GOTO into") - SHOW_PARSE_LABEL(" ", not_error) + SHOW_PARSE_LABEL_OK(" ", not_error) } IF( compute_error->structs.compute_error->compute_error_code, eq_op, integer_zero_node ) { @@ -5526,7 +6020,7 @@ parser_assign( size_t nC, cbl_num_result_t *C, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT(" Laying down on_error LABEL BOTTOM:") - SHOW_PARSE_LABEL(" ", on_error) + SHOW_PARSE_LABEL_OK(" ", on_error) } gg_append_statement( on_error->structs.arith_error->bottom.label ); } @@ -5537,7 +6031,7 @@ parser_assign( size_t nC, cbl_num_result_t *C, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT(" Laying down not_error LABEL BOTTOM:") - SHOW_PARSE_LABEL(" ", not_error) + SHOW_PARSE_LABEL_OK(" ", not_error) } gg_append_statement( not_error->structs.arith_error->bottom.label ); } @@ -5549,16 +6043,16 @@ parser_assign( size_t nC, cbl_num_result_t *C, } static cbl_figconst_t -is_figconst(cbl_field_t *field) +is_figconst_t(const cbl_field_t *field) { cbl_figconst_t figconst = (cbl_figconst_t)(field->attr & FIGCONST_MASK); return figconst; } static cbl_figconst_t -is_figconst(cbl_refer_t &sourceref) +is_figconst(const cbl_refer_t &sourceref) { - return is_figconst(sourceref.field); + return is_figconst_t(sourceref.field); } void @@ -5812,10 +6306,18 @@ parser_initialize_table(size_t nelem, } typedef size_t span_t[2]; static_assert(sizeof(spans[0]) == sizeof(span_t), "pair size wrong"); - static tree tspans = gg_define_variable(SIZE_T_P, "..pit_v1", vs_file_static); - static tree ttbls = gg_define_variable(SIZE_T_P, "..pit_v2", vs_file_static); - gg_assign(tspans, build_array_of_size_t(2*nspan, (const size_t *)spans)); - gg_assign(ttbls, build_array_of_size_t(2*ntbl, (const size_t *)tbls)); + static tree tspans = gg_define_variable(SIZE_T_P, + "..pit_v1", + vs_file_static); + static tree ttbls = gg_define_variable(SIZE_T_P, + "..pit_v2", +vs_file_static); + gg_assign(tspans, + build_array_of_size_t(2*nspan, + reinterpret_cast<const size_t *>(spans))); + gg_assign(ttbls, + build_array_of_size_t(2*ntbl, + reinterpret_cast<const size_t *>(tbls))); gg_call(VOID, "__gg__mirror_range", @@ -5859,7 +6361,7 @@ tree_type_from_field_type(cbl_field_t *field, size_t &nbytes) case FldNumericDisplay: case FldNumericBinary: case FldPacked: - if( field->data.digits > 18 ) + if( field->data.digits > 18 ) { retval = UINT128; nbytes = 16; @@ -5912,19 +6414,19 @@ tree_type_from_field_type(cbl_field_t *field, size_t &nbytes) break; default: - cbl_internal_error( "%s(): Invalid field type %s:", + cbl_internal_error( "%s: Invalid field type %s:", __func__, cbl_field_type_str(field->type)); break; } - } - if( retval == SIZE_T && field->attr & signable_e ) - { - retval = SSIZE_T; - } - if( retval == UINT128 && field->attr & signable_e ) - { - retval = INT128; + if( retval == SIZE_T && field->attr & signable_e ) + { + retval = SSIZE_T; + } + if( retval == UINT128 && field->attr & signable_e ) + { + retval = INT128; + } } return retval; } @@ -5940,12 +6442,13 @@ restore_local_variables() static inline bool is_valuable( cbl_field_type_t type ) { + /* The name of this routine is a play on words, in English. It doesn't + mean "Is worth a lot". It means "Can be converted to a value." */ switch ( type ) { case FldInvalid: case FldGroup: case FldAlphanumeric: case FldNumericEdited: - case FldAlphaEdited: case FldLiteralA: case FldClass: case FldConditional: @@ -5958,6 +6461,7 @@ is_valuable( cbl_field_type_t type ) { // COBOL form to a little-endian binary representation so that they // can be conveyed BY CONTENT/BY VALUE in a CALL or user-defined // function activation. + case FldAlphaEdited: case FldNumericDisplay: case FldNumericBinary: case FldFloat: @@ -5968,11 +6472,11 @@ is_valuable( cbl_field_type_t type ) { case FldPointer: return true; } - cbl_internal_error( "%s:%d: invalid symbol_type_t %d", __func__, __LINE__, type ); + cbl_internal_error( "%s:%d: invalid %<symbol_type_t%> %d", __func__, __LINE__, type ); return false; } -void parser_sleep(cbl_refer_t seconds) +void parser_sleep(const cbl_refer_t &seconds) { if( seconds.field ) { @@ -5992,7 +6496,7 @@ void parser_sleep(cbl_refer_t seconds) // This is a naked place-holding CONTINUE. Generate some do-nothing // code that will stick some .LOC information into the assembly language, // so that GDB-COBOL can display the CONTINUE statement. - gg_assign(var_decl_nop, build_int_cst_type(INT, 103)); + insert_nop(103); } } @@ -6012,7 +6516,7 @@ parser_exit_program(void) // exits back to COBOL only, else continue static void -pe_stuff(cbl_refer_t refer, ec_type_t ec) +program_end_stuff(cbl_refer_t refer, ec_type_t ec) { // This is the moral equivalent of a C "return xyz;". @@ -6035,9 +6539,6 @@ pe_stuff(cbl_refer_t refer, ec_type_t ec) gg_assign(retval, gg_cast(return_type, integer_zero_node)); - gg_modify_function_type(current_function->function_decl, - return_type); - if( is_valuable( field_type ) ) { // The field being returned is numeric. @@ -6078,12 +6579,12 @@ pe_stuff(cbl_refer_t refer, ec_type_t ec) tree array_type = build_array_type_nelts(UCHAR, returner->data.capacity); - tree retval = gg_define_variable(array_type, vs_static); - gg_memcpy(gg_get_address_of(retval), + tree array = gg_define_variable(array_type, vs_static); + gg_memcpy(gg_get_address_of(array), member(returner->var_decl_node, "data"), member(returner->var_decl_node, "capacity")); - tree actual = gg_cast(COBOL_FUNCTION_RETURN_TYPE, gg_get_address_of(retval)); + tree actual = gg_cast(COBOL_FUNCTION_RETURN_TYPE, gg_get_address_of(array)); restore_local_variables(); gg_return(actual); @@ -6103,7 +6604,7 @@ pe_stuff(cbl_refer_t refer, ec_type_t ec) } void -parser_exit( cbl_refer_t refer, ec_type_t ec ) +parser_exit( const cbl_refer_t& refer, ec_type_t ec ) { Analyze(); SHOW_PARSE @@ -6140,7 +6641,7 @@ parser_exit( cbl_refer_t refer, ec_type_t ec ) IF( current_function->called_by_main_counter, eq_op, integer_zero_node ) { // This function wasn't called by main, so we treat it like a GOBACK - pe_stuff(refer, ec); + program_end_stuff(refer, ec); } ELSE { @@ -6151,7 +6652,7 @@ parser_exit( cbl_refer_t refer, ec_type_t ec ) // This was a recursive call into the function originally called by // main. Because we are under the control of a calling program, we // treat this like a GOBACK - pe_stuff(refer, ec); + program_end_stuff(refer, ec); } ELSE { @@ -6176,7 +6677,7 @@ parser_exit( cbl_refer_t refer, ec_type_t ec ) { } ENDIF - pe_stuff(refer, ec); + program_end_stuff(refer, ec); } } @@ -6339,7 +6840,6 @@ parser_arith_error(cbl_label_t *arithmetic_label) // We are entering either SIZE ERROR or NOT SIZE ERROR code RETURN_IF_PARSE_ONLY; - set_up_on_exception_label(arithmetic_label); SHOW_PARSE { @@ -6352,6 +6852,10 @@ parser_arith_error(cbl_label_t *arithmetic_label) SHOW_PARSE_END } + CHECK_LABEL(arithmetic_label); + + set_up_on_exception_label(arithmetic_label); + // Jump over the [NOT] ON EXCEPTION code that is about to be laid down gg_append_statement( arithmetic_label->structs.arith_error->over.go_to ); // Create the label that allows the following code to be executed at @@ -6378,6 +6882,8 @@ parser_arith_error_end(cbl_label_t *arithmetic_label) SHOW_PARSE_END } + CHECK_LABEL(arithmetic_label); + // Jump to the end of the arithmetic code: gg_append_statement( arithmetic_label->structs.arith_error->bottom.go_to ); // Lay down the label that allows the ERROR/NOT ERROR instructions @@ -6561,8 +7067,6 @@ parser_division(cbl_division_t division, SHOW_PARSE_END } - gg_set_current_line_number(CURRENT_LINE_NUMBER); - if( division == data_div_e ) { Analyze(); @@ -6667,7 +7171,7 @@ parser_division(cbl_division_t division, // gg_printf("Somebody wants to cancel %s\n", // gg_string_literal(current_function->our_unmangled_name), // NULL_TREE); - cbl_label_t *prog = cbl_label_of(symbol_at(current_program_index())); + const cbl_label_t *prog = cbl_label_of(symbol_at(current_program_index())); size_t initializer_index = prog->initial_section; cbl_label_t *initializer = cbl_label_of(symbol_at(initializer_index)); parser_perform(initializer, true); // true means suppress nexting @@ -6688,6 +7192,10 @@ parser_division(cbl_division_t division, { parser_local_add(returning); current_function->returning = returning; + + size_t nbytes = 0; + tree returning_type = tree_type_from_field_type(returning, nbytes); + gg_modify_function_type(current_function->function_decl, returning_type); } // Stash the returning variables for use during parser_return() @@ -6710,7 +7218,6 @@ parser_division(cbl_division_t division, // expected formal parameter and tacks it onto the end of the // function's arguments chain. - char ach[2*sizeof(cbl_name_t)]; sprintf(ach, "_p_%s", args[i].refer.field->name); size_t nbytes = 0; @@ -6730,14 +7237,13 @@ parser_division(cbl_division_t division, chain_parameter_to_function(current_function->function_decl, par_type, ach); } - bool check_for_parameter_count = false; - if( nusing ) { // During the call, we saved the parameter_count and an array of variable // lengths. We need to look at those values if, and only if, one or more // of our USING arguments has an OPTIONAL flag or if one of our targets is // marked as VARYING. + bool check_for_parameter_count = false; for(size_t i=0; i<nusing; i++) { if( args[i].optional ) @@ -6784,7 +7290,7 @@ parser_division(cbl_division_t division, // There are 'nusing' elements in the PROCEDURE DIVISION USING list. - tree parameter; + tree parameter = NULL_TREE; tree rt_i = gg_define_int(); for(size_t i=0; i<nusing; i++) { @@ -6933,7 +7439,6 @@ parser_division(cbl_division_t division, // If so, we have to give var2::data_pointer the same value as // var1::data_pointer // - cbl_field_t *next_var; size_t our_index = symbol_index(symbol_elem_of(new_var)); size_t next_index = our_index + 1; // Look ahead in the symbol table for the next LEVEL01/77 @@ -6944,7 +7449,7 @@ parser_division(cbl_division_t division, { break; } - next_var = cbl_field_of(e); + cbl_field_t *next_var = cbl_field_of(e); if( !next_var ) { break; @@ -7019,6 +7524,11 @@ parser_division(cbl_division_t division, ENDIF } ENDIF + // The first token_location that the parser establishes is caused by the + // parser scanning all of the lines in the source code. This messes up the + // logic for backing up one line, which is needed to correctly step through + // COBOL code with GDB-COBOL. So, we clear it here. + current_location_minus_one_clear(); } } @@ -7114,20 +7624,20 @@ parser_logop( struct cbl_field_t *tgt, if( tgt->type != FldConditional ) { - cbl_internal_error("parser_logop() was called with variable %s on line %d" - ", which is not a FldConditional\n", + cbl_internal_error("%<parser_logop()%> was called with variable %s on line %d" + ", which is not a FldConditional", tgt->name, cobol_location().first_line); } if( a && a->type != FldConditional ) { - cbl_internal_error("parser_logop() was called with variable %s on line %d" - ", which is not a FldConditional\n", + cbl_internal_error("%<parser_logop()%> was called with variable %s on line %d" + ", which is not a FldConditional", a->name, cobol_location().first_line); } if( b && b->type != FldConditional ) { - cbl_internal_error("parser_logop() was called with variable %s on line %d" - ", which is not a FldConditional\n", + cbl_internal_error("%<parser_logop()%> was called with variable %s on line %d" + ", which is not a FldConditional", b->name, cobol_location().first_line); } @@ -7233,9 +7743,9 @@ parser_relop( cbl_field_t *tgt, if( tgt->type != FldConditional ) { - cbl_internal_error("parser_relop() was called with variable %s, " - "which is not a FldConditional\n", - tgt->name); + cbl_internal_error("%<parser_relop%> was called with variable %qs, " + "which is not a FldConditional", + tgt->name); } static tree comp_res = gg_define_variable(INT, "..pr_comp_res", vs_file_static); @@ -7297,8 +7807,8 @@ parser_relop_long(cbl_field_t *tgt, if( tgt->type != FldConditional ) { - cbl_internal_error("parser_relop() was called with variable %s, " - "which is not a FldConditional\n", + cbl_internal_error("%<parser_relop()%> was called with variable %s, " + "which is not a FldConditional", tgt->name); } @@ -7343,8 +7853,8 @@ parser_if( struct cbl_field_t *conditional ) if( conditional->type != FldConditional ) { - cbl_internal_error("parser_if() was called with variable %s, " - "which is not a FldConditional\n", + cbl_internal_error("%<parser_if()%> was called with variable %s, " + "which is not a FldConditional", conditional->name); } @@ -7463,7 +7973,9 @@ label_fetch(struct cbl_label_t *label) if( !label->structs.goto_trees ) { label->structs.goto_trees - = (cbl_label_addresses_t *)xmalloc(sizeof(struct cbl_label_addresses_t) ); + = static_cast<cbl_label_addresses_t *> + (xmalloc(sizeof(struct cbl_label_addresses_t))); + gcc_assert(label->structs.goto_trees); gg_create_goto_pair(&label->structs.goto_trees->go_to, &label->structs.goto_trees->label); @@ -7481,15 +7993,18 @@ parser_label_label(struct cbl_label_t *label) SHOW_PARSE_HEADER SHOW_PARSE_LABEL("", label) char ach[32]; - sprintf(ach, " label is at %p", (void*)label); + sprintf(ach, " label is at %p", static_cast<void*>(label)); SHOW_PARSE_TEXT(ach) - sprintf(ach, " label->proc is %p", (void*)label->structs.proc); + if( label ) + { + sprintf(ach, + " label->proc is %p", + static_cast<void*>(label->structs.proc)); + } SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } - CHECK_LABEL(label); - TRACE1 { TRACE1_HEADER @@ -7497,6 +8012,8 @@ parser_label_label(struct cbl_label_t *label) TRACE1_END } + CHECK_LABEL(label); + if(strcmp(label->name, "_end_declaratives") == 0 ) { suppress_cobol_entry_point = false; @@ -7508,21 +8025,25 @@ void parser_label_goto(struct cbl_label_t *label) { label->used = yylineno; + Analyze(); SHOW_PARSE { SHOW_PARSE_HEADER SHOW_PARSE_LABEL(" ", label) char ach[32]; - sprintf(ach, " label is at %p", (void*)label); + sprintf(ach, " label is at %p", static_cast<void*>(label)); SHOW_PARSE_TEXT(ach) - sprintf(ach, " label->proc is %p", (void*)label->structs.proc); + if( label ) + { + sprintf(ach, + " label->proc is %p", + static_cast<void*>(label->structs.proc)); + } SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } - CHECK_LABEL(label); - TRACE1 { TRACE1_HEADER @@ -7530,7 +8051,9 @@ parser_label_goto(struct cbl_label_t *label) TRACE1_END } - if(strcmp(label->name, "_end_declaratives") == 0 ) + CHECK_LABEL(label); + + if( strcmp(label->name, "_end_declaratives") == 0 ) { suppress_cobol_entry_point = true; } @@ -7594,20 +8117,19 @@ parser_setop( struct cbl_field_t *tgt, integer_zero_node)); break; default: - dbgmsg("###### %10s in %s:%d\n", __func__, __FILE__, __LINE__ ); - cbl_internal_error( - "###### candidate %s has unimplemented CVT_type %d(%s)\n", - candidate->name, - candidate->type, - cbl_field_type_str(candidate->type)); + dbgmsg("%10s in %s:%d", __func__, __FILE__, __LINE__ ); + cbl_internal_error("candidate %s has unimplemented %<CVT_type%> %d(%s)", + candidate->name, + candidate->type, + cbl_field_type_str(candidate->type)); gcc_unreachable(); break; } break; default: - dbgmsg("###### %10s in %s:%d\n", __func__, __FILE__, __LINE__ ); - cbl_internal_error("###### unknown setop_t code %d\n", op); + dbgmsg("%10s in %s:%d", __func__, __FILE__, __LINE__ ); + cbl_internal_error("unknown %<setop_t%> code %d", op); gcc_unreachable(); break; } @@ -7615,7 +8137,7 @@ parser_setop( struct cbl_field_t *tgt, void parser_classify( cbl_field_t *tgt, - cbl_refer_t candidate, + const cbl_refer_t &candidate, enum classify_t type ) { Analyze(); @@ -7660,9 +8182,9 @@ parser_classify( cbl_field_t *tgt, } void -parser_perform(struct cbl_perform_tgt_t *tgt, struct cbl_refer_t how_many) +parser_perform(const cbl_perform_tgt_t *tgt, cbl_refer_t how_many) { - cbl_field_t *N = how_many.field; + const cbl_field_t *N = how_many.field; // No SHOW_PARSE here; we want to fall through: if( !tgt->to() ) { @@ -7712,14 +8234,6 @@ create_iline_address_pairs(struct cbl_perform_tgt_t *tgt) gg_create_goto_pair(&tgt->addresses.setup.go_to, &tgt->addresses.setup.label); - - // Even in -O0 compilations, the compiler does some elementary optimizations - // around JMP instructions. We have the SETUP code for in-line performats - // in an island at the end of the loop code. With this intervention, NEXTing - // through the code shows you the final statement of the loop before the - // loop actually starts. - - tgt->addresses.line_number_of_setup_code = gg_get_current_line_number(); } void @@ -7733,7 +8247,7 @@ parser_perform_start( struct cbl_perform_tgt_t *tgt ) { SHOW_PARSE_TEXT(" cbl_perform_tgt_t is at") char ach[32]; - sprintf(ach, " %p", (void*)tgt); + sprintf(ach, " %p", static_cast<void*>(tgt)); SHOW_PARSE_TEXT(ach); SHOW_PARSE_LABEL(" ", tgt->from()) if( tgt->to() ) @@ -7782,7 +8296,7 @@ parser_perform_start( struct cbl_perform_tgt_t *tgt ) // Give GDB-COBOL something to chew on when NEXTing. This instruction will // get the line number of the PERFORM N TIMES code. gg_append_statement(tgt->addresses.top.label); - gg_assign(var_decl_nop, build_int_cst_type(INT, 104)); + insert_nop(104); } void @@ -7794,17 +8308,18 @@ parser_perform_conditional( struct cbl_perform_tgt_t *tgt ) SHOW_PARSE_HEADER SHOW_PARSE_TEXT(" cbl_perform_tgt_t is at") char ach[32]; - sprintf(ach, " %p", (void*)tgt); + sprintf(ach, " %p", static_cast<void*>(tgt)); SHOW_PARSE_TEXT(ach); SHOW_PARSE_END } - size_t i = tgt->addresses.number_of_conditionals; + unsigned int i = tgt->addresses.number_of_conditionals; if( !(i < MAXIMUM_UNTILS) ) { - cbl_internal_error("%s:%d: %zu exceeds MAXIMUM_UNTILS of %d, line %d", - __func__, __LINE__, i, MAXIMUM_UNTILS, CURRENT_LINE_NUMBER); + cbl_internal_error("%s:%d: %u exceeds %<MAXIMUM_UNTILS%> of %d, line %d", + __func__, __LINE__, + i, MAXIMUM_UNTILS, CURRENT_LINE_NUMBER); } gcc_assert(i < MAXIMUM_UNTILS); @@ -7843,12 +8358,12 @@ parser_perform_conditional_end( struct cbl_perform_tgt_t *tgt ) SHOW_PARSE_HEADER SHOW_PARSE_TEXT(" cbl_perform_tgt_t is at") char ach[32]; - sprintf(ach, " %p", (void*)tgt); + sprintf(ach, " %p", static_cast<void*>(tgt)); SHOW_PARSE_TEXT(ach); SHOW_PARSE_END } - size_t i = tgt->addresses.number_of_conditionals; + unsigned int i = tgt->addresses.number_of_conditionals; gcc_assert(i); // We need to cap off the prior conditional in this chain of conditionals @@ -7933,6 +8448,7 @@ perform_outofline_before_until(struct cbl_perform_tgt_t *tgt, sprintf(ach, "_procretb." HOST_SIZE_T_PRINT_DEC ":", (fmt_size_t)our_pseudo_label); + token_location_override(current_location_minus_one()); gg_insert_into_assembler( ach ); } @@ -7996,6 +8512,7 @@ perform_outofline_after_until(struct cbl_perform_tgt_t *tgt, sprintf(ach, "_procretb." HOST_SIZE_T_PRINT_DEC ":", (fmt_size_t)our_pseudo_label); + token_location_override(current_location_minus_one()); gg_insert_into_assembler( ach ); } @@ -8116,6 +8633,7 @@ perform_outofline_testafter_varying(struct cbl_perform_tgt_t *tgt, sprintf(ach, "_procretb." HOST_SIZE_T_PRINT_DEC ":", (fmt_size_t)our_pseudo_label); + token_location_override(current_location_minus_one()); gg_insert_into_assembler( ach ); } @@ -8259,6 +8777,7 @@ perform_outofline_before_varying( struct cbl_perform_tgt_t *tgt, sprintf(ach, "_procretb." HOST_SIZE_T_PRINT_DEC ":", (fmt_size_t)our_pseudo_label); + token_location_override(current_location_minus_one()); gg_insert_into_assembler( ach ); } @@ -8338,8 +8857,6 @@ perform_inline_until( struct cbl_perform_tgt_t *tgt, GOTO TOP EXIT: */ - gg_set_current_line_number(cobol_location().last_line); - gg_append_statement(tgt->addresses.test.label); // Go to where the conditional is recalculated.... @@ -8454,8 +8971,6 @@ perform_inline_testbefore_varying( struct cbl_perform_tgt_t *tgt, parser_move(varys[i].varying, varys[i].from); } - gg_set_current_line_number(cobol_location().last_line); - // Lay down the testing cycle: for(size_t i=0; i<N; i++) { @@ -8767,7 +9282,7 @@ parser_perform_until( struct cbl_perform_tgt_t *tgt, SHOW_PARSE_HEADER SHOW_PARSE_TEXT(" cbl_perform_tgt_t is at") char ach[32]; - sprintf(ach, " %p", (void*)tgt); + sprintf(ach, " %p", static_cast<void*>(tgt)); SHOW_PARSE_TEXT(ach); SHOW_PARSE_LABEL(" ", tgt->from()) if( tgt->to() ) @@ -8777,9 +9292,6 @@ parser_perform_until( struct cbl_perform_tgt_t *tgt, SHOW_PARSE_END } - gg_set_current_line_number(cobol_location().last_line); - gg_assign(var_decl_nop, build_int_cst_type(INT, 105)); - if( tgt->from()->type != LblLoop ) { perform_outofline( tgt, test_before, N, varys); @@ -8846,10 +9358,6 @@ parser_perform_inline_times(struct cbl_perform_tgt_t *tgt, gg_append_statement( tgt->addresses.testA.label ); gg_append_statement( tgt->addresses.test.label ); - // AT this point, we want to set the line_number to the location of the - // END-PERFORM statement. - gg_set_current_line_number(cobol_location().last_line); - gg_decrement(counter); // Do the test: IF( counter, gt_op, gg_cast(LONG, integer_zero_node) ) @@ -8880,8 +9388,6 @@ parser_perform_inline_times(struct cbl_perform_tgt_t *tgt, SHOW_PARSE_END } - int stash = gg_get_current_line_number(); - gg_set_current_line_number(tgt->addresses.line_number_of_setup_code); gg_append_statement( tgt->addresses.setup.label ); // Get the count: @@ -8912,8 +9418,6 @@ parser_perform_inline_times(struct cbl_perform_tgt_t *tgt, gg_append_statement( tgt->addresses.exit.go_to ); ENDIF - gg_set_current_line_number(stash); - SHOW_PARSE { SHOW_PARSE_INDENT @@ -8924,7 +9428,7 @@ parser_perform_inline_times(struct cbl_perform_tgt_t *tgt, } void -parser_set_conditional88( struct cbl_refer_t refer, bool which_way ) +parser_set_conditional88( const cbl_refer_t& refer, bool which_way ) { Analyze(); struct cbl_field_t *tgt = refer.field; @@ -9036,7 +9540,7 @@ parser_file_add(struct cbl_file_t *file) if( !file ) { - cbl_internal_error("%s(): called with NULL *file", __func__); + cbl_internal_error("%s: called with NULL *file", __func__); gcc_assert(file); } @@ -9161,7 +9665,7 @@ parser_file_add(struct cbl_file_t *file) if(file->access == file_inaccessible_e) { cbl_internal_error( - "%s:%d file %s access mode is 'file_inaccessible_e' in %s", + "%s:%d file %s access mode is %<file_inaccessible_e%> in %s", current_filename.back().c_str(), CURRENT_LINE_NUMBER, file->name, @@ -9235,12 +9739,13 @@ parser_file_open( struct cbl_file_t *file, int mode_char ) if( !file ) { - cbl_internal_error("parser_file_open called with NULL *file"); + cbl_internal_error("%<parser_file_open%> called with NULL *file"); } if( !file->var_decl_node ) { - cbl_internal_error("parser_file_open for %s called with NULL var_decl_node", file->name); + cbl_internal_error("%<parser_file_open%> for %s called with NULL " + "%<var_decl_node%>", file->name); } if( mode_char == 'a' && (file->access != file_access_seq_e) ) @@ -9281,6 +9786,7 @@ parser_file_open( struct cbl_file_t *file, int mode_char ) quoted_name = true; } + sv_is_i_o = true; store_location_stuff("OPEN"); gg_call(VOID, "__gg__file_open", @@ -9313,12 +9819,13 @@ parser_file_close( struct cbl_file_t *file, file_close_how_t how ) if( !file ) { - cbl_internal_error("parser_file_close called with NULL *file"); + cbl_internal_error("%<parser_file_close%> called with NULL *file"); } if( !file->var_decl_node ) { - cbl_internal_error("parser_file_close for %s called with NULL file->var_decl_node", file->name); + cbl_internal_error("%<parser_file_close%> for %s called with " + "NULL %<file->var_decl_node%>", file->name); } TRACE1 @@ -9332,6 +9839,7 @@ parser_file_close( struct cbl_file_t *file, file_close_how_t how ) // We are done with the filename. The library routine will free "filename" // memory and set it back to null + sv_is_i_o = true; store_location_stuff("CLOSE"); gg_call(VOID, "__gg__file_close", @@ -9381,27 +9889,29 @@ parser_file_read( struct cbl_file_t *file, if( !file ) { - cbl_internal_error("parser_file_read called with NULL *file"); + cbl_internal_error("%<parser_file_read%> called with NULL *file"); } if( !file->var_decl_node ) { - cbl_internal_error("parser_file_read for %s called with NULL file->var_decl_node", file->name); + cbl_internal_error("%<parser_file_read%> for %s called with " + "NULL %<file->var_decl_node%>", file->name); } if( !file ) { - cbl_internal_error("parser_file_read called with NULL *field"); + cbl_internal_error("%<parser_file_read%> called with NULL *field"); } if( !file->var_decl_node ) { - cbl_internal_error("parser_file_read for %s called with NULL field->var_decl_node", file->name); + cbl_internal_error("%<parser_file_read%> for %s called with " + "NULL %<field->var_decl_node%>", file->name); } if( file->access == file_access_seq_e && where >= 0) { - cbl_internal_error("%s:%d file %s is RELATIVE/SEQUENTIAL, but 'where' >= 0", + cbl_internal_error("%s:%d file %s is RELATIVE/SEQUENTIAL, but %<where >= 0%>", current_filename.back().c_str(), CURRENT_LINE_NUMBER, file->name); @@ -9410,13 +9920,14 @@ parser_file_read( struct cbl_file_t *file, if( file->access == file_access_rnd_e && where < 0) { - cbl_internal_error("%s:%d file %s is RELATIVE/RANDOM, but 'where' < 0", + cbl_internal_error("%s:%d file %s is RELATIVE/RANDOM, but %<where < 0%>", current_filename.back().c_str(), CURRENT_LINE_NUMBER, file->name); where = 1; } + sv_is_i_o = true; store_location_stuff("READ"); gg_call(VOID, "__gg__file_read", @@ -9497,23 +10008,23 @@ parser_file_write( cbl_file_t *file, if( !file ) { - cbl_internal_error("%s(): called with NULL *file", __func__); + cbl_internal_error("%s: called with NULL *file", __func__); } if( !file->var_decl_node ) { - cbl_internal_error("%s(): for %s called with NULL file->var_decl_node", + cbl_internal_error("%s: for %s called with NULL %<file->var_decl_node%>", __func__, file->name); } if( !file ) { - cbl_internal_error("%s(): called with NULL *field", __func__); + cbl_internal_error("%s: called with NULL *field", __func__); } if( !file->var_decl_node ) { - cbl_internal_error( "%s(): for %s called with NULL field->var_decl_node", + cbl_internal_error( "%s: for %s called with NULL %<field->var_decl_node%>", __func__, file->name); } @@ -9551,6 +10062,7 @@ parser_file_write( cbl_file_t *file, record_area = cbl_field_of(symbol_at(file->default_record)); } + sv_is_i_o = true; store_location_stuff("WRITE"); gg_call(VOID, "__gg__file_write", @@ -9594,13 +10106,19 @@ void parser_file_delete( struct cbl_file_t *file, bool /*sequentially*/ ) { Analyze(); + + if( !file ) + { + cbl_internal_error("The file pointer should not be null"); + abort(); // Because cppcheck doesn't recognize [[noerror]] + } + bool sequentially = file->access == file_access_seq_e || file->org == file_sequential_e || file->org == file_line_sequential_e; SHOW_PARSE { SHOW_PARSE_HEADER - if(file) { SHOW_PARSE_TEXT(" "); SHOW_PARSE_TEXT(file->name); @@ -9613,13 +10131,10 @@ parser_file_delete( struct cbl_file_t *file, bool /*sequentially*/ ) SHOW_PARSE_TEXT(" sequentially") } } - else - { - SHOW_PARSE_TEXT(" *file is NULL") - } SHOW_PARSE_END } + sv_is_i_o = true; store_location_stuff("DELETE"); gg_call(VOID, "__gg__file_delete", @@ -9676,6 +10191,7 @@ parser_file_rewrite(cbl_file_t *file, record_area = cbl_field_of(symbol_at(file->default_record)); } + sv_is_i_o = true; store_location_stuff("REWRITE"); gg_call(VOID, "__gg__file_rewrite", @@ -9771,8 +10287,8 @@ parser_file_start(struct cbl_file_t *file, // A key has a number of fields for(size_t ifield=0; ifield<file->keys[key_number].nfield; ifield++) { - size_t field_index = file->keys[key_number].fields[ifield]; - cbl_field_t *field = cbl_field_of(symbol_at(field_index)); + size_t nfield = file->keys[key_number].fields[ifield]; + cbl_field_t *field = cbl_field_of(symbol_at(nfield)); combined_length += field->data.capacity; } gg_assign(length, build_int_cst_type(SIZE_T, combined_length)); @@ -9785,6 +10301,7 @@ parser_file_start(struct cbl_file_t *file, refer_offset(length_ref)); } + sv_is_i_o = true; store_location_stuff("START"); gg_call(VOID, "__gg__file_start", @@ -9798,15 +10315,53 @@ parser_file_start(struct cbl_file_t *file, static void inspect_tally(bool backward, - cbl_refer_t identifier_1, - unsigned long n_identifier_2, - cbx_inspect_t<cbl_refer_t>* identifier_2) + const cbl_refer_t &identifier_1, + cbl_inspect_opers_t& identifier_2) { Analyze(); // This is an INSPECT FORMAT 1 SHOW_PARSE { SHOW_PARSE_HEADER + char ach[128]; + sprintf(ach, "There are %lu identifier_2", gb4(identifier_2.size())); + SHOW_PARSE_TEXT(ach); + for(size_t i=0; i<identifier_2.size(); i++) + { + SHOW_PARSE_INDENT + sprintf(ach, "%lu: bounds: %lu", gb4(i), gb4(identifier_2[i].nbound())); + SHOW_PARSE_TEXT(ach); + for(size_t j=0; j<identifier_2[i].nbound(); j++) + { + SHOW_PARSE_INDENT + sprintf(ach, " %lu: matches: %lu", + gb4(j), gb4(identifier_2[i][j].matches.size())); + SHOW_PARSE_TEXT(ach); + + SHOW_PARSE_INDENT + if( identifier_2[i][j].bound == bound_characters_e ) + { + SHOW_PARSE_TEXT(" bound_characters"); + } + else + { + SHOW_PARSE_TEXT(" bound_leading/all"); + } + + if( identifier_2[i][j].matches.size() ) + { + SHOW_PARSE_INDENT + sprintf(ach, " before %p", + as_voidp(identifier_2.at(i).at(j).matches.at(0).before.identifier_4.field)); + SHOW_PARSE_TEXT(ach); + SHOW_PARSE_INDENT + sprintf(ach, " after %p", + as_voidp(identifier_2.at(i).at(j).matches.at(0).after.identifier_4.field)); + SHOW_PARSE_TEXT(ach); + } + } + } + SHOW_PARSE_END } @@ -9816,6 +10371,7 @@ inspect_tally(bool backward, size_t int_index = 0; size_t pcbl_index = 0; + unsigned long n_identifier_2 = identifier_2.size(); // The first integer is the all-important controlling count: int_index++; @@ -9829,12 +10385,11 @@ inspect_tally(bool backward, pcbl_index++; // For each FOR there is a count of the loops after the FOR int_index++; - for(size_t j=0; j<identifier_2[i].nbound; j++) + for(size_t j=0; j<identifier_2[i].nbound(); j++) { - // After each identifier-2, there is a cbl_inspect_bound_t value: int_index++; - if( identifier_2[i].opers[j].bound == bound_characters_e) + if( identifier_2[i][j].bound == bound_characters_e) { // This is a FOR CHARACTERS PHRASE1, so we will need before/after // for each: @@ -9845,7 +10400,7 @@ inspect_tally(bool backward, { // This is ALL or LEADING. Each has some number of identifier-3 int_index++; - for(size_t k=0; k<identifier_2[i].opers[j].n_identifier_3; k++) + for(size_t k=0; k<identifier_2[i][j].n_identifier_3(); k++) { // Put identifier-3 into the array: pcbl_index++; @@ -9881,8 +10436,8 @@ inspect_tally(bool backward, } ENDIF - size_t n_resolveds = pcbl_index; - cbl_refer_t *pcbl_refers = (cbl_refer_t *)xmalloc(n_resolveds * sizeof(cbl_refer_t)); + const size_t n_resolveds = pcbl_index; + std::vector<cbl_refer_t> pcbl_refers(n_resolveds); // Now we make a second pass, populating those arrays: int_index = 0; @@ -9901,34 +10456,42 @@ inspect_tally(bool backward, pcbl_refers[pcbl_index++] = identifier_2[i].tally; // For each FOR there is a count of the loops after the FOR gg_assign( gg_array_value(integers, int_index++), - build_int_cst_type(SIZE_T, identifier_2[i].nbound) ); - for(size_t j=0; j<identifier_2[i].nbound; j++) + build_int_cst_type(SIZE_T, identifier_2[i].nbound()) ); + for(size_t j=0; j<identifier_2[i].nbound(); j++) { // After each identifier-2, there is a cbl_inspect_bound_t value: gg_assign( gg_array_value(integers, int_index++), - build_int_cst_type(SIZE_T, identifier_2[i].opers[j].bound)); - if( identifier_2[i].opers[j].bound == bound_characters_e) + build_int_cst_type(SIZE_T, identifier_2[i][j].bound)); + if( identifier_2[i][j].bound == bound_characters_e) { // This is a FOR CHARACTERS PHRASE1, so we will need before/after // for each: - pcbl_refers[pcbl_index++] = identifier_2[i].opers[j].matches[0].before.identifier_4; - pcbl_refers[pcbl_index++] = identifier_2[i].opers[j].matches[0].after.identifier_4; + const auto& m( identifier_2[i][j].matches ); + if( m.empty() ) + { + pcbl_index += 2; + } + else + { + pcbl_refers[pcbl_index++] = m[0].before.identifier_4; + pcbl_refers[pcbl_index++] = m[0].after.identifier_4; + } } else { // This is ALL or LEADING. Each has some number of identifier-3 gg_assign( gg_array_value(integers, int_index++), - build_int_cst_type(SIZE_T, identifier_2[i].opers[j].n_identifier_3)); - for(size_t k=0; k<identifier_2[i].opers[j].n_identifier_3; k++) + build_int_cst_type(SIZE_T, identifier_2[i][j].n_identifier_3())); + for(size_t k=0; k<identifier_2[i][j].n_identifier_3(); k++) { // Put identifier-3 into the array: - pcbl_refers[pcbl_index++] = identifier_2[i].opers[j].matches[k].matching; + pcbl_refers[pcbl_index++] = identifier_2[i][j].matches[k].matching(); // We need the PHRASE1 for that identifier-3 - pcbl_refers[pcbl_index++] = identifier_2[i].opers[j].matches[k].before.identifier_4; + pcbl_refers[pcbl_index++] = identifier_2[i][j].matches[k].before.identifier_4; - pcbl_refers[pcbl_index++] = identifier_2[i].opers[j].matches[k].after.identifier_4; + pcbl_refers[pcbl_index++] = identifier_2[i][j].matches[k].after.identifier_4; } } } @@ -9940,7 +10503,7 @@ inspect_tally(bool backward, gcc_assert(pcbl_index == n_resolveds); // We have built up an array of integers, and an array of cbl_refer_t. - build_array_of_treeplets(1, pcbl_index, pcbl_refers); + build_array_of_treeplets(1, pcbl_index, pcbl_refers.data()); // Do the actual call: gg_call(VOID, @@ -9948,16 +10511,12 @@ inspect_tally(bool backward, backward ? integer_one_node : integer_zero_node, integers, NULL_TREE); - - // And free up the memory we allocated - free(pcbl_refers); } static void inspect_replacing(int backward, - cbl_refer_t identifier_1, - unsigned long n_ops, - cbx_inspect_t<cbl_refer_t>* operations) + const cbl_refer_t &identifier_1, + cbl_inspect_opers_t &operations) { Analyze(); // This is an INSPECT FORMAT 2 @@ -9968,6 +10527,7 @@ inspect_replacing(int backward, } // For REPLACING, unlike TALLY, there can be but one operation + unsigned long n_ops = operations.size(); gcc_assert(n_ops == 1); size_t n_id_3 = 0; @@ -9978,9 +10538,9 @@ inspect_replacing(int backward, // Make one pass through the inputs to count up the sizes of the arrays // we will be passing to the library routines: - for( size_t j=0; j<operations[0].nbound; j++) + for( size_t j=0; j<operations[0].nbound(); j++) { - if( operations[0].opers[j].bound == bound_characters_e) + if( operations[0][j].bound == bound_characters_e) { // This is a FOR CHARACTERS phrase @@ -9999,13 +10559,13 @@ inspect_replacing(int backward, // The n_identifier-3 values will go into the resolved values; we have to // leave room for them - n_id_3 += operations[0].opers[j].n_identifier_3; + n_id_3 += operations[0][j].n_identifier_3(); // Likewise identifier-5 values: - n_id_5 += operations[0].opers[j].n_identifier_3; + n_id_5 += operations[0][j].n_identifier_3(); // And each identifier-3 / identifier-5 pair has BEFORE and AFTER phrases: - n_id_4 += 2 * operations[0].opers[j].n_identifier_3; + n_id_4 += 2 * operations[0][j].n_identifier_3(); } } @@ -10013,8 +10573,8 @@ inspect_replacing(int backward, // all the integers and cbl_inspect_bound_t values, in a strict sequence so // that the library routine can peel them off. - size_t n_integers = 1 // Room for operations[0].nbound - + operations[0].nbound // Room for all the cbl_inspect_bound_t values + size_t n_integers = 1 // Room for operations[0].nbound() + + operations[0].nbound() // Room for all the cbl_inspect_bound_t values + n_all_leading_first; // Room for all of the n_identifier_3 counts static tree int_size = gg_define_variable(INT, "..pir_size", vs_file_static, 0); @@ -10034,12 +10594,12 @@ inspect_replacing(int backward, } ENDIF - size_t n_resolveds = 1 // Room for identifier-1 + const size_t n_resolveds = 1 // Room for identifier-1 + n_id_3 // Room for the identifier-3 variables + n_id_4 // Room for the identifier-4 variables + n_id_5; // Room for the identifier-5 variables - cbl_refer_t *pcbl_refers = (cbl_refer_t *)xmalloc(n_resolveds * sizeof(cbl_refer_t)); + std::vector<cbl_refer_t> pcbl_refers(n_resolveds); // Now we make a second pass, populating those arrays: size_t int_index = 0; @@ -10047,28 +10607,28 @@ inspect_replacing(int backward, // The first integer is the all-important controlling count: gg_assign( gg_array_value(integers, int_index++), - build_int_cst_type(SIZE_T, operations[0].nbound) ); + build_int_cst_type(SIZE_T, operations[0].nbound()) ); // The first refer is for identifier-1 pcbl_refers[pcbl_index++] = identifier_1; - for( size_t j=0; j<operations[0].nbound; j++) + for( size_t j=0; j<operations[0].nbound(); j++) { // For each FOR there is a count of the loops after the FOR // For each operation, there is a cbl_inspect_bound_t value: gg_assign( gg_array_value(integers, int_index++), - build_int_cst_type(SIZE_T, operations[0].opers[j].bound)); - if( operations[0].opers[j].bound == bound_characters_e) + build_int_cst_type(SIZE_T, operations[0][j].bound)); + if( operations[0][j].bound == bound_characters_e) { // This is a FOR CHARACTERS PHRASE1 // Put in the identifier-5 replacement value: - pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[0].replacement; + pcbl_refers[pcbl_index++] = operations[0][j].replaces[0].replacement; // Each identifier-5 gets a PHRASE1: - pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[0].before.identifier_4; - pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[0].after.identifier_4; + pcbl_refers[pcbl_index++] = operations[0][j].replaces[0].before.identifier_4; + pcbl_refers[pcbl_index++] = operations[0][j].replaces[0].after.identifier_4; SHOW_PARSE { @@ -10076,14 +10636,14 @@ inspect_replacing(int backward, { SHOW_PARSE_INDENT } - SHOW_PARSE_FIELD("ID-5 ", operations[0].opers[j].replaces[0].replacement.field) - if(operations[0].opers[j].replaces[0].before.identifier_4.field) + SHOW_PARSE_FIELD("ID-5 ", operations[0][j].replaces[0].replacement.field) + if(operations[0][j].replaces[0].before.identifier_4.field) { - SHOW_PARSE_FIELD(" before ", operations[0].opers[j].replaces[0].before.identifier_4.field) + SHOW_PARSE_FIELD(" before ", operations[0][j].replaces[0].before.identifier_4.field) } - if(operations[0].opers[j].replaces[0].after.identifier_4.field) + if(operations[0][j].replaces[0].after.identifier_4.field) { - SHOW_PARSE_FIELD(" after ", operations[0].opers[j].replaces[0].after.identifier_4.field) + SHOW_PARSE_FIELD(" after ", operations[0][j].replaces[0].after.identifier_4.field) } SHOW_PARSE_END } @@ -10092,19 +10652,19 @@ inspect_replacing(int backward, { // This is ALL or LEADING. Each has some number of identifier-3/identifier-5 pairs gg_assign( gg_array_value(integers, int_index++), - build_int_cst_type(SIZE_T, operations[0].opers[j].n_identifier_3)); - for(size_t k=0; k<operations[0].opers[j].n_identifier_3; k++) + build_int_cst_type(SIZE_T, operations[0][j].n_identifier_3())); + for(size_t k=0; k<operations[0][j].n_identifier_3(); k++) { // Put identifier-3 into the array: - pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[k].matching; + pcbl_refers[pcbl_index++] = operations[0][j].replaces[k].matching(); // Put in the identifier-5 replacement value: - pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[k].replacement; + pcbl_refers[pcbl_index++] = operations[0][j].replaces[k].replacement; // We need the PHRASE1 for that identifier-3/identifier-5 pair: - pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[k].before.identifier_4; + pcbl_refers[pcbl_index++] = operations[0][j].replaces[k].before.identifier_4; - pcbl_refers[pcbl_index++] = operations[0].opers[j].replaces[k].after.identifier_4; + pcbl_refers[pcbl_index++] = operations[0][j].replaces[k].after.identifier_4; SHOW_PARSE { @@ -10112,15 +10672,15 @@ inspect_replacing(int backward, { SHOW_PARSE_INDENT } - SHOW_PARSE_FIELD("ID-3 ", operations[0].opers[j].replaces[k].matching.field) - SHOW_PARSE_FIELD(" ID-5 ", operations[0].opers[j].replaces[k].replacement.field) - if( operations[0].opers[j].replaces[k].before.identifier_4.field ) + SHOW_PARSE_FIELD("ID-3 ", operations[0][j].replaces[k].matching().field) + SHOW_PARSE_FIELD(" ID-5 ", operations[0][j].replaces[k].replacement.field) + if( operations[0][j].replaces[k].before.identifier_4.field ) { - SHOW_PARSE_FIELD("before ", operations[0].opers[j].replaces[k].before.identifier_4.field) + SHOW_PARSE_FIELD("before ", operations[0][j].replaces[k].before.identifier_4.field) } - if(operations[0].opers[j].replaces[k].after.identifier_4.field) + if(operations[0][j].replaces[k].after.identifier_4.field) { - SHOW_PARSE_FIELD("after ", operations[0].opers[j].replaces[k].after.identifier_4.field) + SHOW_PARSE_FIELD("after ", operations[0][j].replaces[k].after.identifier_4.field) } SHOW_PARSE_END } @@ -10128,9 +10688,9 @@ inspect_replacing(int backward, } } - //fprintf(stderr, "%s(): %ld %ld\n", __func__, int_index, n_integers); + //fprintf(stderr, "%s: %ld %ld\n", __func__, int_index, n_integers); gcc_assert(int_index == n_integers); - //fprintf(stderr, "%s(): %ld %ld\n", __func__, pcbl_index, n_resolveds); + //fprintf(stderr, "%s: %ld %ld\n", __func__, pcbl_index, n_resolveds); gcc_assert(pcbl_index == n_resolveds); // We have built up an array of integers, and an array of cbl_refer_t. @@ -10145,7 +10705,7 @@ inspect_replacing(int backward, } } - build_array_of_treeplets(1, pcbl_index, pcbl_refers); + build_array_of_treeplets(1, pcbl_index, pcbl_refers.data()); // Do the actual call: gg_call(VOID, @@ -10156,13 +10716,12 @@ inspect_replacing(int backward, } void -parser_inspect(cbl_refer_t identifier_1, +parser_inspect(const cbl_refer_t& identifier_1, bool backward, - size_t n_operations, - cbx_inspect_t<cbl_refer_t>* operations) + cbl_inspect_opers_t& operations) { Analyze(); - gcc_assert(n_operations); + gcc_assert(! operations.empty()); /* Operating philosophy: We are going to minimize the amount of GENERIC tag creation here at compile time, mainly by eliminating @@ -10172,12 +10731,12 @@ parser_inspect(cbl_refer_t identifier_1, if( operations[0].tally.field ) { // This is a FORMAT 1 "TALLYING" - inspect_tally(backward, identifier_1, n_operations, operations); + inspect_tally(backward, identifier_1, operations); } else { // This is a FORMAT 2 "REPLACING" - inspect_replacing(backward, identifier_1, n_operations, operations); + inspect_replacing(backward, identifier_1, operations); } } @@ -10297,7 +10856,7 @@ parser_intrinsic_numval_c( cbl_field_t *f, void parser_intrinsic_subst( cbl_field_t *f, - cbl_refer_t& ref1, + const cbl_refer_t& ref1, size_t argc, cbl_substitute_t * argv ) { @@ -10320,10 +10879,13 @@ parser_intrinsic_subst( cbl_field_t *f, TRACE1_END } + sv_is_i_o = true; store_location_stuff("SUBSTITUTE"); - unsigned char *control_bytes = (unsigned char *)xmalloc(argc * sizeof(unsigned char)); - cbl_refer_t *arg1 = (cbl_refer_t *)xmalloc(argc * sizeof(cbl_refer_t)); - cbl_refer_t *arg2 = (cbl_refer_t *)xmalloc(argc * sizeof(cbl_refer_t)); + unsigned char *control_bytes = + static_cast<unsigned char *>(xmalloc(argc * sizeof(unsigned char))); + gcc_assert(control_bytes); + std::vector<cbl_refer_t> arg1(argc); + std::vector<cbl_refer_t> arg2(argc); for(size_t i=0; i<argc; i++) { @@ -10339,8 +10901,8 @@ parser_intrinsic_subst( cbl_field_t *f, tree control = gg_array_of_bytes(argc, control_bytes); - build_array_of_treeplets(1, argc, arg1); - build_array_of_treeplets(2, argc, arg2); + build_array_of_treeplets(1, argc, arg1.data()); + build_array_of_treeplets(2, argc, arg2.data()); gg_call(VOID, "__gg__substitute", @@ -10354,8 +10916,6 @@ parser_intrinsic_subst( cbl_field_t *f, gg_free(control); - free(arg2); - free(arg1); free(control_bytes); } @@ -10449,7 +11009,9 @@ parser_intrinsic_call_0(cbl_field_t *tgt, { // Pass __gg__when_compiled() the time from right now. struct timespec tp; - clock_gettime(CLOCK_REALTIME, &tp); // time_t tv_sec; long tv_nsec + uint64_t now = get_time_nanoseconds(); + tp.tv_sec = now / 1000000000; + tp.tv_nsec = now % 1000000000; store_location_stuff(function_name); gg_call(VOID, @@ -10504,15 +11066,15 @@ parser_intrinsic_call_1( cbl_field_t *tgt, } size_t upper = ref1.field->occurs.bounds.upper ? ref1.field->occurs.bounds.upper : 1; - if( ref1.nsubscript ) + if( ref1.nsubscript() ) { upper = 1; } - if( is_table(ref1.field) && !ref1.nsubscript ) + if( is_table(ref1.field) && !ref1.nsubscript() ) { static tree depending_on = gg_define_variable(LONG, "..pic1_dep"); - gg_get_depending_on_value(depending_on, ref1.field); + depending_on_value(depending_on, ref1.field); gg_call(VOID, "__gg__int128_to_field", gg_get_address_of(tgt->var_decl_node), @@ -10758,7 +11320,9 @@ static void create_lsearch_address_pairs(struct cbl_label_t *name) { // Create the lsearch structure - name->structs.lsearch = (cbl_lsearch_t *)xmalloc(sizeof(cbl_lsearch_t)); + name->structs.lsearch = + static_cast<cbl_lsearch_t *>(xmalloc(sizeof(cbl_lsearch_t))); + gcc_assert(name->structs.lsearch); cbl_lsearch_t *lsearch = name->structs.lsearch; gg_create_goto_pair(&lsearch->addresses.at_exit.go_to, @@ -10822,7 +11386,7 @@ parser_lsearch_start( cbl_label_t *name, { // Extract the number of elements in that rightmost dimension. lsearch->limit = gg_define_variable(LONG); - gg_get_depending_on_value(lsearch->limit, current); + depending_on_value(lsearch->limit, current); break; } current = parent_of(current); @@ -11008,7 +11572,9 @@ parser_bsearch_start( cbl_label_t* name, } // We need a cbl_bsearch_t structure: - name->structs.bsearch = (cbl_bsearch_t *)xmalloc(sizeof(cbl_bsearch_t)); + name->structs.bsearch = + static_cast<cbl_bsearch_t *>(xmalloc(sizeof(cbl_bsearch_t))); + gcc_assert(name->structs.bsearch); cbl_bsearch_t *bsearch = name->structs.bsearch; // Create the address/label pairs we need @@ -11041,6 +11607,8 @@ parser_bsearch_start( cbl_label_t* name, current = parent_of(current); } + CHECK_FIELD(current); + // There are a number of things we learn from the field "current" // We get the index: @@ -11059,7 +11627,7 @@ parser_bsearch_start( cbl_label_t* name, // Assign the left and right values: gg_assign(bsearch->left, build_int_cst_type(LONG, 1)); - gg_get_depending_on_value(bsearch->right, current); + depending_on_value(bsearch->right, current); // Create the variable that will take the compare result. bsearch->compare_result = gg_define_int(); @@ -11148,12 +11716,11 @@ parser_bsearch_conditional( cbl_label_t* name ) } bool -is_ascending_key(cbl_refer_t key) +is_ascending_key(const cbl_refer_t& key) { bool retval = true; cbl_field_t *family_tree = key.field; - gcc_assert(family_tree); while( family_tree ) { if( family_tree->occurs.nkey ) @@ -11162,14 +11729,17 @@ is_ascending_key(cbl_refer_t key) } family_tree = parent_of(family_tree); } + + CHECK_FIELD(family_tree); gcc_assert(family_tree->occurs.nkey); + for(size_t i=0; i<family_tree->occurs.nkey; i++) { for(size_t j=0; j<family_tree->occurs.keys[i].field_list.nfield; j++) { size_t index_of_field = family_tree->occurs.keys[i].field_list.fields[j]; - cbl_field_t *key_field = cbl_field_of(symbol_at(index_of_field)); + const cbl_field_t *key_field = cbl_field_of(symbol_at(index_of_field)); if( strcmp( key_field->name, key.field->name ) == 0 ) @@ -11295,8 +11865,7 @@ void parser_sort(cbl_refer_t tableref, bool duplicates, cbl_alphabet_t *alphabet, - size_t nkeys, - cbl_key_t *keys ) + const std::vector<cbl_key_t>& keys ) { Analyze(); SHOW_PARSE @@ -11314,22 +11883,26 @@ parser_sort(cbl_refer_t tableref, gcc_assert(table->var_decl_node); if( !is_table(table) ) { - cbl_internal_error( "%s(): asked to sort %s, but it's not a table", + cbl_internal_error( "%s: asked to sort %s, which is not a table", __func__, tableref.field->name); } - size_t total_keys = 0; - for( size_t i=0; i<nkeys; i++ ) - { - total_keys += keys[i].nfield; - } - cbl_field_t **flattened_fields = (cbl_field_t **)xmalloc(total_keys * sizeof(cbl_field_t *)); - size_t *flattened_ascending = (size_t *)xmalloc(total_keys * sizeof(size_t)); + size_t total_keys = std::accumulate( keys.begin(), keys.end(), 0, + [](size_t n, const cbl_key_t& key ) { + return n + key.fields.size(); + } ); + typedef const cbl_field_t * const_field_t; + const_field_t *flattened_fields = + static_cast<const_field_t *>(xmalloc(total_keys * sizeof(cbl_field_t *))); + gcc_assert(flattened_fields); + size_t *flattened_ascending = + static_cast<size_t *>(xmalloc(total_keys * sizeof(size_t))); + gcc_assert(flattened_ascending); size_t key_index = 0; - for( size_t i=0; i<nkeys; i++ ) + for( size_t i=0; i<keys.size(); i++ ) { - for( size_t j=0; j<keys[i].nfield; j++ ) + for( size_t j=0; j<keys[i].fields.size(); j++ ) { flattened_fields[key_index] = keys[i].fields[j]; flattened_ascending[key_index] = keys[i].ascending ? 1 : 0; @@ -11338,13 +11911,14 @@ parser_sort(cbl_refer_t tableref, } // Create the array of cbl_field_t pointers for the keys - tree all_keys = gg_array_of_field_pointers( total_keys, flattened_fields); + tree all_keys = gg_array_of_field_pointers( total_keys, + const_cast<cbl_field_t**>(flattened_fields)); // Create the array of integers that are the flags for ASCENDING: tree ascending = gg_array_of_size_t( total_keys, flattened_ascending ); tree depending_on = gg_define_variable(LONG, "_sort_size"); - gg_get_depending_on_value(depending_on, table); + depending_on_value(depending_on, table); if( alphabet ) { @@ -11377,8 +11951,7 @@ void parser_file_sort( cbl_file_t *workfile, bool duplicates, cbl_alphabet_t *alphabet, - size_t nkeys, - cbl_key_t *keys, + const std::vector<cbl_key_t>& keys, size_t ninput, cbl_file_t **inputs, size_t noutput, @@ -11442,7 +12015,7 @@ parser_file_sort( cbl_file_t *workfile, else { // Having both or neither violates SORT syntax - cbl_internal_error("%s(): syntax error -- both (or neither) USING " + cbl_internal_error("%s: syntax error: both (or neither) USING " "and input-proc are specified", __func__); } @@ -11455,18 +12028,22 @@ parser_file_sort( cbl_file_t *workfile, // clone of the code for handling multiple keys, each of which can have // multiple fields. - size_t total_keys = 0; - for( size_t i=0; i<nkeys; i++ ) - { - total_keys += keys[i].nfield; - } - cbl_field_t **flattened_fields = (cbl_field_t **)xmalloc(total_keys * sizeof(cbl_field_t *)); - size_t *flattened_ascending = (size_t *) xmalloc(total_keys * sizeof(size_t)); + size_t total_keys = std::accumulate( keys.begin(), keys.end(), 0, + []( size_t n, const cbl_key_t& key ) { + return n + key.fields.size(); + } ); + typedef const cbl_field_t * const_field_t; + auto flattened_fields + = static_cast<const_field_t *>(xmalloc(total_keys * sizeof(cbl_field_t *))); + gcc_assert(flattened_fields); + size_t *flattened_ascending = + static_cast<size_t *>(xmalloc(total_keys * sizeof(size_t))); + gcc_assert(flattened_ascending); size_t key_index = 0; - for( size_t i=0; i<nkeys; i++ ) + for( size_t i=0; i<keys.size(); i++ ) { - for( size_t j=0; j<keys[i].nfield; j++ ) + for( size_t j=0; j<keys[i].fields.size(); j++ ) { flattened_fields[key_index] = keys[i].fields[j]; flattened_ascending[key_index] = keys[i].ascending ? 1 : 0; @@ -11475,7 +12052,8 @@ parser_file_sort( cbl_file_t *workfile, } // Create the array of cbl_field_t pointers for the keys - tree all_keys = gg_array_of_field_pointers( total_keys, flattened_fields); + tree all_keys = gg_array_of_field_pointers( total_keys, + const_cast<cbl_field_t**>(flattened_fields)); // Create the array of integers that are the flags for ASCENDING: tree ascending = gg_array_of_size_t( total_keys, flattened_ascending ); @@ -11571,7 +12149,7 @@ parser_file_sort( cbl_file_t *workfile, } else { - cbl_internal_error("%s(): syntax error -- both (or neither) GIVING " + cbl_internal_error("%s: syntax error: both (or neither) GIVING " "and output-proc are specified", __func__); } } @@ -11619,7 +12197,9 @@ parser_return_start( cbl_file_t *workfile, cbl_refer_t into ) // We assume that workfile is open. - workfile->addresses = (cbl_sortreturn_t *)xmalloc(sizeof(cbl_sortreturn_t)); + workfile->addresses = static_cast<cbl_sortreturn_t *> + (xmalloc(sizeof(cbl_sortreturn_t))); + gcc_assert(workfile->addresses); gg_create_goto_pair(&workfile->addresses->at_end.go_to, &workfile->addresses->at_end.label); gg_create_goto_pair(&workfile->addresses->not_at_end.go_to, @@ -11777,8 +12357,7 @@ gg_array_of_file_pointers( size_t N, void parser_file_merge( cbl_file_t *workfile, cbl_alphabet_t *alphabet, - size_t nkeys, - cbl_key_t *keys, + const std::vector<cbl_key_t>& keys, size_t ninputs, cbl_file_t **inputs, size_t noutputs, @@ -11801,20 +12380,23 @@ parser_file_merge( cbl_file_t *workfile, build_int_cst_type(INT, file_sequential_e)); } - size_t total_keys = 0; - for( size_t i=0; i<nkeys; i++ ) - { - total_keys += keys[i].nfield; - } - cbl_field_t **flattened_fields - = (cbl_field_t **)xmalloc(total_keys * sizeof(cbl_field_t *)); + size_t total_keys = std::accumulate( keys.begin(), keys.end(), 0, + []( size_t i, const cbl_key_t& key ) { + return i + key.fields.size(); + } ); + typedef const cbl_field_t * const_field_t; + const_field_t *flattened_fields + = static_cast<const_field_t *> + (xmalloc(total_keys * sizeof(cbl_field_t *))); + gcc_assert(flattened_fields); size_t *flattened_ascending - = (size_t *)xmalloc(total_keys * sizeof(size_t)); + = static_cast<size_t *>(xmalloc(total_keys * sizeof(size_t))); + gcc_assert(flattened_ascending); size_t key_index = 0; - for( size_t i=0; i<nkeys; i++ ) + for( size_t i=0; i<keys.size(); i++ ) { - for( size_t j=0; j<keys[i].nfield; j++ ) + for( size_t j=0; j<keys[i].fields.size(); j++ ) { flattened_fields[key_index] = keys[i].fields[j]; flattened_ascending[key_index] = keys[i].ascending ? 1 : 0; @@ -11823,7 +12405,9 @@ parser_file_merge( cbl_file_t *workfile, } // Create the array of cbl_field_t pointers for the keys - tree all_keys = gg_array_of_field_pointers(total_keys, flattened_fields); + tree all_keys = gg_array_of_field_pointers( + total_keys, + const_cast<cbl_field_t**>(flattened_fields)); // Create the array of integers that are the flags for ASCENDING: tree ascending = gg_array_of_size_t(total_keys, flattened_ascending); @@ -11847,6 +12431,9 @@ parser_file_merge( cbl_file_t *workfile, ELSE ENDIF + const cbl_enabled_exceptions_t& + enabled_exceptions( cdf_enabled_exceptions() ); + for(size_t i=0; i<ninputs; i++) { if( process_this_exception(ec_sort_merge_file_open_e) ) @@ -11890,7 +12477,7 @@ parser_file_merge( cbl_file_t *workfile, gg_call(VOID, "__gg__merge_files", gg_get_address_of(workfile->var_decl_node), - build_int_cst_type(SIZE_T, nkeys), + build_int_cst_type(SIZE_T, keys.size()), all_keys, ascending, build_int_cst_type(SIZE_T, ninputs), @@ -11984,7 +12571,7 @@ parser_file_merge( cbl_file_t *workfile, } else { - cbl_internal_error("%s(): syntax error -- both (or neither) " + cbl_internal_error("%s: syntax error: both (or neither) " "files and output-proc are specified", __func__); } } @@ -12004,7 +12591,8 @@ parser_string_overflow( cbl_label_t *name ) */ name->structs.unstring - = (cbl_unstring_t *)xmalloc(sizeof(struct cbl_unstring_t) ); + = static_cast<cbl_unstring_t *>(xmalloc(sizeof(struct cbl_unstring_t))); + gcc_assert(name->structs.unstring); // Set up the address pairs for this clause gg_create_goto_pair(&name->structs.unstring->over.go_to, @@ -12062,9 +12650,9 @@ parser_unstring(cbl_refer_t src, gg_append_statement(not_overflow->structs.unstring->over.label); } - cbl_refer_t *delims = (cbl_refer_t *)xmalloc(ndelimited * sizeof(cbl_refer_t)); - char *alls = (char *)xmalloc(ndelimited+1); - + std::vector<cbl_refer_t> delims(ndelimited); + char *alls = static_cast<char *>(xmalloc(ndelimited+1)); + gcc_assert(alls); for(size_t i=0; i<ndelimited; i++) { delims[i] = delimiteds[i]; @@ -12074,7 +12662,7 @@ parser_unstring(cbl_refer_t src, tree t_alls = build_string_literal(ndelimited+1, alls); - build_array_of_treeplets(1, ndelimited, delims); + build_array_of_treeplets(1, ndelimited, delims.data()); build_array_of_treeplets(2, noutputs, outputs); build_array_of_treeplets(3, noutputs, delimiters); build_array_of_treeplets(4, noutputs, counts); @@ -12098,7 +12686,6 @@ parser_unstring(cbl_refer_t src, NULL_TREE) ); free(alls); - free(delims); if( overflow ) { @@ -12134,12 +12721,12 @@ parser_unstring(cbl_refer_t src, } void -parser_string( cbl_refer_t tgt, - cbl_refer_t pointer, - size_t nsource, - cbl_string_src_t *sources, - cbl_label_t *overflow, - cbl_label_t *not_overflow ) +parser_string(const cbl_refer_t& tgt, + const cbl_refer_t& pointer, + size_t nsource, + cbl_string_src_t *sources, + cbl_label_t *overflow, + cbl_label_t *not_overflow ) { SHOW_PARSE { @@ -12156,7 +12743,8 @@ parser_string( cbl_refer_t tgt, } // We need an array of nsource+1 integers: - size_t *integers = (size_t *)xmalloc((nsource+1)*sizeof(size_t)); + size_t *integers = static_cast<size_t *>(xmalloc((nsource+1)*sizeof(size_t))); + gcc_assert(integers); // Count up how many treeplets we are going to need: size_t cblc_count = 2; // tgt and pointer @@ -12165,7 +12753,7 @@ parser_string( cbl_refer_t tgt, cblc_count += 1 + sources[i].ninput; // 1 for identifier_2 + ninput identifier_1 values; } - cbl_refer_t *refers = (cbl_refer_t *)xmalloc(cblc_count * sizeof(cbl_refer_t)); + std::vector<cbl_refer_t> refers(cblc_count); size_t index_int = 0; size_t index_cblc = 0; @@ -12190,7 +12778,7 @@ parser_string( cbl_refer_t tgt, tree pintegers = build_array_of_size_t( index_int, integers); - build_array_of_treeplets(1, index_cblc, refers); + build_array_of_treeplets(1, index_cblc, refers.data()); tree t_overflow = gg_define_int(); gg_assign(t_overflow, gg_call_expr( INT, @@ -12200,7 +12788,6 @@ parser_string( cbl_refer_t tgt, gg_free(pintegers); free(integers); - free(refers); if( overflow ) { @@ -12248,8 +12835,9 @@ parser_call_exception( cbl_label_t *name ) } name->structs.call_exception - = (cbl_call_exception_t *)xmalloc(sizeof(struct cbl_call_exception_t) ); - + = static_cast<cbl_call_exception_t *> + (xmalloc(sizeof(struct cbl_call_exception_t))); + gcc_assert(name->structs.call_exception); // Set up the address pairs for this clause gg_create_goto_pair(&name->structs.call_exception->over.go_to, &name->structs.call_exception->over.label); @@ -12297,11 +12885,11 @@ static void create_and_call(size_t narg, cbl_ffi_arg_t args[], - tree function_handle, + tree function_pointer, + const char *funcname, tree returned_value_type, cbl_refer_t returned, - cbl_label_t *not_except - ) + cbl_label_t *not_except) { // We have a good function handle, so we are going to create a call tree *arguments = NULL; @@ -12309,8 +12897,10 @@ create_and_call(size_t narg, if(narg) { - arguments = (tree *)xmalloc(2*narg * sizeof(tree)); - allocated = (int * )xmalloc(narg * sizeof(int)); + arguments = static_cast<tree *>(xmalloc(2*narg * sizeof(tree))); + gcc_assert(arguments); + allocated = static_cast<int *>(xmalloc(narg * sizeof(int))); + gcc_assert(allocated); } // Put the arguments onto the "stack" of calling parameters: @@ -12522,28 +13112,67 @@ create_and_call(size_t narg, gg_assign(var_decl_call_parameter_count, build_int_cst_type(INT, narg)); - gg_assign(var_decl_call_parameter_signature, - gg_cast(CHAR_P, function_handle)); + tree call_expr = NULL_TREE; + if( function_pointer ) + { + gg_assign(var_decl_call_parameter_signature, + gg_cast(CHAR_P, function_pointer)); + + call_expr = gg_call_expr_list(returned_value_type, + function_pointer, + narg, + arguments ); + } + else + { + tree fndecl_type = build_varargs_function_type_array( returned_value_type, + 0, // No parameters yet + NULL); // And, hence, no types + + // Fetch the FUNCTION_DECL for that FUNCTION_TYPE + tree function_decl = gg_build_fn_decl(funcname, fndecl_type); + set_call_convention(function_decl, current_call_convention()); + + // Take the address of the function decl: + tree address_of_function = gg_get_address_of(function_decl); + + // Stash that address as the called program's signature: + tree address_as_char_p = gg_cast(CHAR_P, address_of_function); + tree assigment = gg_assign( var_decl_call_parameter_signature, + address_as_char_p); + // The source of the assigment is the second element of a MODIFY_EXPR + parser_call_target( funcname, assigment ); - tree call_expr = gg_call_expr_list( returned_value_type, - function_handle, + // Create the call_expr from that address + call_expr = build_call_array_loc( gg_token_location(), + returned_value_type, + address_of_function, narg, - arguments ); + arguments); + // Among other possibilities, this might be a forward reference to a + // contained function. The name here is "prog2", and ultimately will need + // to be replaced with a call to "prog2.62". So, this call expr goes into + // a list of call expressions whose function_decl targets will be replaced. + parser_call_target( funcname, call_expr ); + } + tree returned_value; + if( returned.field ) { - returned_value = gg_define_variable(returned_value_type); + // Because the CALL had a RETURNING clause, RETURN-CODE doesn't return a + // value. So, we make sure it is zero + //// gg_assign(var_decl_return_code, build_int_cst_type(SHORT, 0)); + + // We expect the return value to be a 64-bit or 128-bit integer. How + // we treat that returned value depends on the target. - // We are expecting a return value of type CHAR_P, SSIZE_T, SIZE_T, - // UINT128 or INT128 + // Pick up that value: + returned_value = gg_define_variable(returned_value_type); push_program_state(); gg_assign(returned_value, gg_cast(returned_value_type, call_expr)); pop_program_state(); - // Because the CALL had a RETURNING clause, RETURN-CODE doesn't return a - // value. So, we make sure it is zero -//// gg_assign(var_decl_return_code, build_int_cst_type(SHORT, 0)); - if( returned_value_type == CHAR_P ) { tree returned_location = gg_define_uchar_star(); @@ -12637,7 +13266,7 @@ create_and_call(size_t narg, else { cbl_internal_error( - "%s(): What in the name of Nero's fiddle are we doing here?", + "%s: What in the name of Nero are we doing here?", __func__); } } @@ -12692,7 +13321,7 @@ parser_call( cbl_refer_t name, SHOW_PARSE_TEXT(" (") for(size_t i=0; i<narg; i++) { - cbl_field_t *p = args[i].refer.field; + const cbl_field_t *p = args[i].refer.field; SHOW_PARSE_FIELD( " ", p) } SHOW_PARSE_TEXT(" )") @@ -12753,39 +13382,49 @@ parser_call( cbl_refer_t name, // We are getting close to establishing the function_type. To do that, // we want to establish the function's return type. -// gg_push_context(); size_t nbytes; tree returned_value_type = tree_type_from_field_type(returned.field, nbytes); - tree function_handle = function_handle_from_name( name, - returned_value_type); - if( (use_static_call() && is_literal(name.field)) - || (name.field && name.field->type == FldPointer) ) + if( use_static_call() && is_literal(name.field) ) + { + // name is a literal + create_and_call(narg, + args, + NULL_TREE, + name.field->data.initial, + returned_value_type, + returned, + not_except); + } + else if( name.field && name.field->type == FldPointer ) { - // If these conditions are true, then we know we have a good - // function_handle, and we don't need to check + tree function_pointer = function_pointer_from_name( name, + returned_value_type); + // This is call-by-pointer; we know function_pointer is good: create_and_call(narg, args, - function_handle, + function_pointer, + nullptr, returned_value_type, returned, - not_except - ); + not_except); } else { + tree function_pointer = function_pointer_from_name( name, + returned_value_type); // We might not have a good handle, so we have to check: - IF( function_handle, + IF( function_pointer, ne_op, - gg_cast(TREE_TYPE(function_handle), null_pointer_node) ) + gg_cast(TREE_TYPE(function_pointer), null_pointer_node) ) { - create_and_call(narg, - args, - function_handle, - returned_value_type, - returned, - not_except - ); + create_and_call(narg, + args, + function_pointer, + nullptr, + returned_value_type, + returned, + not_except); } ELSE { @@ -12833,8 +13472,6 @@ parser_call( cbl_refer_t name, gg_append_statement( not_except->structs.call_exception->bottom.label ); free( not_except->structs.call_exception ); } -// gg_pop_context(); - } // Set global variable to use alternative ENTRY point. @@ -12877,7 +13514,7 @@ parser_bitop( struct cbl_field_t *tgt, // tgt has to be a FldConditional if(tgt && tgt->type != FldConditional) { fprintf(stderr, - "%s(): The target %s has to be a FldConditional, not %s\n", + "%s: The target %s has to be a FldConditional, not %s\n", __func__, tgt->name, cbl_field_type_str(tgt->type)); @@ -12914,7 +13551,7 @@ parser_bitop( struct cbl_field_t *tgt, // tgt has to be a FldConditional case bit_or_op: case bit_xor_op: fprintf(stderr, - "%s(): The %s operation is not valid\n", + "%s: The %s operation is not valid\n", __func__, ops[op]); gcc_unreachable(); @@ -12961,7 +13598,7 @@ parser_bitwise_op(struct cbl_field_t *tgt, if( tgt && !is_valuable(tgt->type) && tgt->type != FldLiteralN) { fprintf(stderr, - "%s(): The target %s has to be is_valuable, not %s\n", + "%s: The target %s has to be is_valuable, not %s\n", __func__, tgt->name, cbl_field_type_str(tgt->type)); @@ -12975,7 +13612,7 @@ parser_bitwise_op(struct cbl_field_t *tgt, case bit_on_op: case bit_off_op: fprintf(stderr, - "%s(): The %s operation is not valid\n", + "%s: The %s operation is not valid\n", __func__, ops[op]); gcc_unreachable(); @@ -13030,10 +13667,10 @@ parser_set_pointers( size_t ntgt, cbl_refer_t *tgts, cbl_refer_t source ) || source.field->type == FldLiteralA)) { // This is something like SET varp TO ENTRY "ref". - tree function_handle = function_handle_from_name(source, + tree function_pointer = function_pointer_from_name(source, COBOL_FUNCTION_RETURN_TYPE); gg_memcpy(qualified_data_location(tgts[i]), - gg_get_address_of(function_handle), + gg_get_address_of(function_pointer), sizeof_pointer); } else @@ -13082,7 +13719,8 @@ typedef struct hier_node hier_node() : our_index(0), common(false), - parent_node(NULL) + parent_node(nullptr), + name(nullptr) {} } hier_node; @@ -13126,7 +13764,7 @@ find_uncles(const hier_node *node, std::vector<const hier_node *> &uncles) } void -parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) +parser_program_hierarchy( const cbl_prog_hier_t& hier ) { Analyze(); /* This routine gets called near the end of every program-id. It keeps @@ -13144,7 +13782,7 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) } else { - for( size_t i=0; i<hier.nlabel; i++ ) + for( size_t i=0; i<hier.labels.size(); i++ ) { if( i ) { @@ -13199,9 +13837,9 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) node_map[0] = nodes.back(); // Pass 1: Create a node for every program: - for( size_t i=0; i<hier.nlabel; i++ ) + for( size_t i=0; i<hier.labels.size(); i++ ) { - hier_node *existing_node = find_hier_node(node_map, hier.labels[i].ordinal); + const hier_node *existing_node = find_hier_node(node_map, hier.labels[i].ordinal); gcc_assert( existing_node == NULL ); hier_node *new_node = new hier_node; @@ -13213,7 +13851,7 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) } // Pass 2: populate each node with their parent and children: - for( size_t i=0; i<hier.nlabel; i++ ) + for( size_t i=0; i<hier.labels.size(); i++ ) { hier_node *child_node = find_hier_node(node_map, hier.labels[i].ordinal); gcc_assert(child_node); @@ -13245,9 +13883,9 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) // are also accessible by us. Go find them. std::vector<const hier_node *>uncles; find_uncles(nodes[i], uncles); - for( size_t i=0; i<uncles.size(); i++ ) + for( size_t j=0; j<uncles.size(); j++ ) { - const hier_node *uncle = uncles[i]; + const hier_node *uncle = uncles[j]; if( map_of_sets[caller].find(uncle->name) == map_of_sets[caller].end() ) { // We have a COMMON uncle or sibling we haven't seen before. @@ -13285,9 +13923,8 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) if( callers.find(caller) == callers.end() ) { // We haven't seen this caller before - callers.insert(caller); - char ach[2*sizeof(cbl_name_t)]; + char ach[3*sizeof(cbl_name_t)]; tree names_table_type = build_array_type_nelts(CHAR_P, mol->second.size()+1); sprintf(ach, "..our_accessible_functions_" HOST_SIZE_T_PRINT_DEC, (fmt_size_t)caller); @@ -13314,7 +13951,9 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) callee != mol->second.end(); callee++ ) { - sprintf(ach, "%s." HOST_SIZE_T_PRINT_DEC, (*callee)->name, + sprintf(ach, + "%s." HOST_SIZE_T_PRINT_DEC, + (*callee)->name, (fmt_size_t)(*callee)->parent_node->our_index); CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr_names), @@ -13350,6 +13989,8 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) (fmt_size_t)caller); tree accessible_programs_decl = gg_trans_unit_var_decl(ach); gg_assign( accessible_programs_decl, gg_get_address_of(the_constructed_table) ); + + callers.insert(caller); } } } @@ -13383,50 +14024,6 @@ parser_set_numeric(struct cbl_field_t *tgt, ssize_t value) NULL_TREE ); } -static void -store_location_stuff(const cbl_name_t statement_name) - { - if( exception_location_active && !current_declarative_section_name() ) - { - // We need to establish some stuff for EXCEPTION- function processing - gg_assign(var_decl_exception_source_file, - gg_string_literal(current_filename.back().c_str())); - - gg_assign(var_decl_exception_program_id, - gg_string_literal(current_function->our_unmangled_name)); - - if( strstr(current_function->current_section->label->name, "_implicit") - != current_function->current_section->label->name ) - { - gg_assign(var_decl_exception_section, - gg_string_literal(current_function->current_section->label->name)); - } - else - { - gg_assign(var_decl_exception_section, - gg_cast(build_pointer_type(CHAR_P),null_pointer_node)); - } - - if( strstr(current_function->current_paragraph->label->name, "_implicit") - != current_function->current_paragraph->label->name ) - { - gg_assign(var_decl_exception_paragraph, - gg_string_literal(current_function->current_paragraph->label->name)); - } - else - { - gg_assign(var_decl_exception_paragraph, - gg_cast(build_pointer_type(CHAR_P), null_pointer_node)); - } - - gg_assign(var_decl_exception_source_file, - gg_string_literal(current_filename.back().c_str())); - gg_assign(var_decl_exception_line_number, build_int_cst_type(INT, - CURRENT_LINE_NUMBER)); - gg_assign(var_decl_exception_statement, gg_string_literal(statement_name)); - } - } - void parser_exception_clear() { @@ -13506,9 +14103,17 @@ parser_check_fatal_exception() TRACE1_END } + // Performance note: + // A simple program that does two billion additions of 32-bit binary numbers + // in its innermost loop had an execution time of 19.5 seconds. By putting in + // the if() statement, that was reduced to 3.8 seconds. + + if( cdf_enabled_exceptions().size() || sv_is_i_o ) + { gg_call(VOID, "__gg__check_fatal_exception", NULL_TREE); + } } void @@ -13522,7 +14127,7 @@ parser_pop_exception() { gg_call(VOID, "__gg__exception_pop", NULL_TREE); } - + void parser_clear_exception() { @@ -13623,7 +14228,7 @@ hijack_for_development(const char *funcname) // Assume that funcname is lowercase with no hyphens enter_program_common(funcname, funcname); parser_display_literal("You have been hijacked by a program named \"dubner\""); - gg_insert_into_assembler("%s HIJACKED DUBNER CODE START", ASM_COMMENT_START); + gg_insert_into_assemblerf("%s HIJACKED DUBNER CODE START", ASM_COMMENT_START); for(int i=0; i<10; i++) { @@ -13636,12 +14241,12 @@ hijack_for_development(const char *funcname) NULL_TREE); } - gg_insert_into_assembler("%s HIJACKED DUBNER CODE END", ASM_COMMENT_START); + gg_insert_into_assemblerf("%s HIJACKED DUBNER CODE END", ASM_COMMENT_START); gg_return(0); } static void -conditional_abs(tree source, cbl_field_t *field) +conditional_abs(tree source, const cbl_field_t *field) { Analyze(); if( !(field->attr & signable_e) ) @@ -13651,9 +14256,9 @@ conditional_abs(tree source, cbl_field_t *field) } static bool -mh_identical(cbl_refer_t &destref, - cbl_refer_t &sourceref, - TREEPLET &tsource) +mh_identical(const cbl_refer_t &destref, + const cbl_refer_t &sourceref, + const TREEPLET &tsource) { // Check to see if the two variables are identical types, thus allowing // for a simple byte-for-byte copy of the data areas: @@ -13675,7 +14280,7 @@ mh_identical(cbl_refer_t &destref, ) { // The source and destination are identical in type - if( (sourceref.field->attr & intermediate_e) || !symbol_find_odo(sourceref.field) ) + if( !symbol_find_odo(sourceref.field) ) { Analyze(); // Source doesn't have a depending_on clause @@ -13957,8 +14562,8 @@ mh_source_is_literalN(cbl_refer_t &destref, default: cbl_internal_error( - "In parser_move(%s to %s), the move of FldLiteralN to %s " - "hasn't been implemented", + "In %<parser_move(%s to %s)%>, the move of FldLiteralN to %s " + "is unimplemented", sourceref.field->name, destref.field->name, cbl_field_type_str(destref.field->type)); @@ -13986,14 +14591,14 @@ tree float_type_of(int n) } static tree -float_type_of(cbl_field_t *field) +float_type_of(const cbl_field_t *field) { gcc_assert(field->type == FldFloat); return float_type_of(field->data.capacity); } static tree -float_type_of(cbl_refer_t *refer) +float_type_of(const cbl_refer_t *refer) { return float_type_of(refer->field); } @@ -14193,8 +14798,8 @@ mh_dest_is_float( cbl_refer_t &destref, } default: - cbl_internal_error("In mh_dest_is_float(%s to %s), the " - "move of %s to %s hasn't been implemented", + cbl_internal_error("In %<mh_dest_is_float%>(%s to %s), the " + "move of %s to %s is unimplemented", sourceref.field->name, destref.field->name, cbl_field_type_str(sourceref.field->type), @@ -14225,7 +14830,7 @@ picky_memset(tree &dest_p, unsigned char value, size_t length) } static void -picky_memcpy(tree &dest_p, tree &source_p, size_t length) +picky_memcpy(tree &dest_p, const tree &source_p, size_t length) { if( length ) { @@ -14244,10 +14849,10 @@ picky_memcpy(tree &dest_p, tree &source_p, size_t length) } static bool -mh_numeric_display( cbl_refer_t &destref, - cbl_refer_t &sourceref, - TREEPLET &tsource, - tree size_error) +mh_numeric_display( const cbl_refer_t &destref, + const cbl_refer_t &sourceref, + const TREEPLET &tsource, + tree size_error) { bool moved = false; @@ -14733,11 +15338,11 @@ mh_numeric_display( cbl_refer_t &destref, } static bool -mh_little_endian( cbl_refer_t &destref, - cbl_refer_t &sourceref, - TREEPLET &tsource, - bool check_for_error, - tree size_error) +mh_little_endian( const cbl_refer_t &destref, + const cbl_refer_t &sourceref, + const TREEPLET &tsource, + bool check_for_error, + tree size_error) { bool moved = false; @@ -14805,9 +15410,9 @@ mh_little_endian( cbl_refer_t &destref, } static bool -mh_source_is_group( cbl_refer_t &destref, - cbl_refer_t &sourceref, - TREEPLET &tsrc) +mh_source_is_group( const cbl_refer_t &destref, + const cbl_refer_t &sourceref, + const TREEPLET &tsrc) { bool retval = false; if( sourceref.field->type == FldGroup && !(destref.field->attr & rjust_e) ) @@ -14872,7 +15477,7 @@ move_helper(tree size_error, // This is an INT { // We are creating a copy of the original destination in case we clobber it // and have to restore it because of a computational error. - bool first_time = true; + static bool first_time = true; static size_t stash_size = 1024; if( first_time ) { @@ -14897,7 +15502,7 @@ move_helper(tree size_error, // This is an INT //goto dont_be_clever; this will go through to the default. } - if( !moved ) + // if( !moved ) // commented out to quiet cppcheck { moved = mh_source_is_group(destref, sourceref, tsource); } @@ -14966,8 +15571,9 @@ move_helper(tree size_error, // This is an INT if( buffer_size < source_length ) { buffer_size = source_length; - buffer = (char *)xrealloc(buffer, buffer_size); + buffer = static_cast<char *>(xrealloc(buffer, buffer_size)); } + gcc_assert(buffer); if( figconst ) { @@ -15110,7 +15716,7 @@ move_helper(tree size_error, // This is an INT gg_attribute_bit_clear(destref.field, refmod_e); } - moved = true; + // moved = true; // commented out to quiet cppcheck } if( restore_on_error ) @@ -15241,7 +15847,8 @@ binary_initial_from_float128(cbl_field_t *field, int rdigits, FIXED_WIDE_INT(128) i = FIXED_WIDE_INT(128)::from (real_to_integer (&value, &fail, 128), SIGNED); - retval = (char *)xmalloc(field->data.capacity); + retval = static_cast<char *>(xmalloc(field->data.capacity)); + gcc_assert(retval); switch(field->data.capacity) { tree type; @@ -15252,7 +15859,7 @@ binary_initial_from_float128(cbl_field_t *field, int rdigits, case 16: type = build_nonstandard_integer_type ( field->data.capacity * BITS_PER_UNIT, 0); - native_encode_wide_int (type, i, (unsigned char *)retval, + native_encode_wide_int (type, i, PTRCAST(unsigned char, retval), field->data.capacity); break; default: @@ -15382,7 +15989,8 @@ initial_from_initial(cbl_field_t *field) } if( set_return ) { - retval = (char *)xmalloc(field->data.capacity+1); + retval = static_cast<char *>(xmalloc(field->data.capacity+1)); + gcc_assert(retval); memset(retval, const_char, field->data.capacity); retval[field->data.capacity] = '\0'; return retval; @@ -15452,7 +16060,8 @@ initial_from_initial(cbl_field_t *field) case FldNumericDisplay: { - retval = (char *)xmalloc(field->data.capacity); + retval = static_cast<char *>(xmalloc(field->data.capacity)); + gcc_assert(retval); char *pretval = retval; char ach[128]; @@ -15469,7 +16078,7 @@ initial_from_initial(cbl_field_t *field) digits_from_float128(ach, field, field->data.digits, rdigits, value); - char *digits = ach; + const char *digits = ach; if( (field->attr & signable_e) && (field->attr & separate_e) && (field->attr & leading_e ) ) @@ -15532,7 +16141,8 @@ initial_from_initial(cbl_field_t *field) case FldPacked: { - retval = (char *)xmalloc(field->data.capacity); + retval = static_cast<char *>(xmalloc(field->data.capacity)); + gcc_assert(retval); char *pretval = retval; char ach[128]; @@ -15558,7 +16168,7 @@ initial_from_initial(cbl_field_t *field) : field->data.capacity * 2 - 1; digits_from_float128(ach, field, ndigits, rdigits, value); - char *digits = ach; + const char *digits = ach; for(size_t i=0; i<ndigits; i++) { if( !(i & 0x01) ) @@ -15599,7 +16209,8 @@ initial_from_initial(cbl_field_t *field) { if( field->data.initial ) { - retval = (char *)xmalloc(field->data.capacity+1); + retval = static_cast<char *>(xmalloc(field->data.capacity+1)); + gcc_assert(retval); if( field->attr & hex_encoded_e) { memcpy(retval, field->data.initial, field->data.capacity); @@ -15607,7 +16218,7 @@ initial_from_initial(cbl_field_t *field) else { size_t buffer_size = 0; - size_t length = (size_t)field->data.capacity; + size_t length = field->data.capacity; memset(retval, internal_space, length); raw_to_internal(&retval, &buffer_size, field->data.initial, length); if( strlen(field->data.initial) < length ) @@ -15623,25 +16234,23 @@ initial_from_initial(cbl_field_t *field) case FldNumericEdited: { - retval = (char *)xmalloc(field->data.capacity+1); + retval = static_cast<char *>(xmalloc(field->data.capacity+1)); + gcc_assert(retval); if( field->data.initial && field->attr & quoted_e ) { - if( field->attr & quoted_e ) + // What the programmer says the value is, the value becomes, no + // matter how wrong it might be. + size_t length = std::min( (size_t)field->data.capacity, + strlen(field->data.initial)); + for(size_t i=0; i<length; i++) { - // What the programmer says the value is, the value becomes, no - // matter how wrong it might be. - size_t length = std::min( (size_t)field->data.capacity, - strlen(field->data.initial)); - for(size_t i=0; i<length; i++) - { - retval[i] = ascii_to_internal(field->data.initial[i]); - } - if( length < (size_t)field->data.capacity ) - { - memset( retval+length, - internal_space, - (size_t)field->data.capacity - length); - } + retval[i] = ascii_to_internal(field->data.initial[i]); + } + if( length < (size_t)field->data.capacity ) + { + memset( retval+length, + internal_space, + (size_t)field->data.capacity - length); } } else @@ -15661,7 +16270,6 @@ initial_from_initial(cbl_field_t *field) char ach[128]; memset(ach, 0, sizeof(ach)); memset(retval, 0, field->data.capacity); - size_t ndigits = field->data.capacity; if( (field->attr & blank_zero_e) && real_iszero (&value) ) { @@ -15669,6 +16277,7 @@ initial_from_initial(cbl_field_t *field) } else { + size_t ndigits = field->data.capacity; digits_from_float128(ach, field, ndigits, rdigits, value); /* ??? This resides in libgcobol valconv.cc. */ __gg__string_to_numeric_edited( retval, @@ -15683,23 +16292,24 @@ initial_from_initial(cbl_field_t *field) case FldFloat: { - retval = (char *)xmalloc(field->data.capacity); + retval = static_cast<char *>(xmalloc(field->data.capacity)); + gcc_assert(retval); switch( field->data.capacity ) { case 4: value = real_value_truncate (TYPE_MODE (FLOAT), value); native_encode_real (SCALAR_FLOAT_TYPE_MODE (FLOAT), &value, - (unsigned char *)retval, 4, 0); + PTRCAST(unsigned char, retval), 4, 0); break; case 8: value = real_value_truncate (TYPE_MODE (DOUBLE), value); native_encode_real (SCALAR_FLOAT_TYPE_MODE (DOUBLE), &value, - (unsigned char *)retval, 8, 0); + PTRCAST(unsigned char, retval), 8, 0); break; case 16: value = real_value_truncate (TYPE_MODE (FLOAT128), value); native_encode_real (SCALAR_FLOAT_TYPE_MODE (FLOAT128), &value, - (unsigned char *)retval, 16, 0); + PTRCAST(unsigned char, retval), 16, 0); break; } break; @@ -16085,12 +16695,13 @@ psa_FldLiteralA(struct cbl_field_t *field ) // First make room static size_t buffer_size = 1024; - static char *buffer = (char *)xmalloc(buffer_size); + static char *buffer = static_cast<char *>(xmalloc(buffer_size)); if( buffer_size < field->data.capacity+1 ) { buffer_size = field->data.capacity+1; - buffer = (char *)xrealloc(buffer, buffer_size); + buffer = static_cast<char *>(xrealloc(buffer, buffer_size)); } + gcc_assert(buffer); cbl_figconst_t figconst = cbl_figconst_of( field->data.initial ); gcc_assert(figconst == normal_value_e); @@ -16111,14 +16722,28 @@ psa_FldLiteralA(struct cbl_field_t *field ) // We have the original nul-terminated text at data.initial. We have a // copy of it in buffer[] in the internal codeset. + static const char name_base[] = "_literal_a_"; + // We will reuse a single static structure for each string static std::unordered_map<std::string, int> seen_before; + std::string field_string(buffer); + +#if 0 + /* This code is suppoed to re-use literals, and seems to work just fine in + x86_64-linux and on an Apple aarch64 M1 Macbook Pro. But on an M1 + mini, using -Os optimization, attempts were made in the generated + assembly language to define _literal_a_1 more than once. + + I didn't know how to try to track this one down, so I decided simply to + punt by removing the code. + + I am leaving the code here because of a conviction that it someday should + be tracked down. */ + std::unordered_map<std::string, int>::const_iterator it = seen_before.find(field_string); - static const char name_base[] = "_literal_a_"; - if( it != seen_before.end() ) { // We've seen that string before. @@ -16131,9 +16756,11 @@ psa_FldLiteralA(struct cbl_field_t *field ) vs_file_static); } else +#endif { // We have not seen that string before - static int nvar = 1; + static int nvar = 0; + nvar += 1; seen_before[field_string] = nvar; char ach[32]; @@ -16143,9 +16770,9 @@ psa_FldLiteralA(struct cbl_field_t *field ) vs_file_static); actually_create_the_static_field( field, - build_string_literal(field->data.capacity+1, + build_string_literal(field->data.capacity, buffer), - field->data.capacity+1, + field->data.capacity, field->data.initial, NULL_TREE, field->var_decl_node); @@ -16153,7 +16780,6 @@ psa_FldLiteralA(struct cbl_field_t *field ) TREE_USED(field->var_decl_node) = 1; TREE_STATIC(field->var_decl_node) = 1; DECL_PRESERVE_P (field->var_decl_node) = 1; - nvar += 1; } // TRACE1 // { @@ -16174,6 +16800,8 @@ parser_local_add(struct cbl_field_t *new_var ) SHOW_PARSE_END } + CHECK_FIELD(new_var); + IF( member(new_var->var_decl_node, "data"), ne_op, gg_cast(UCHAR_P, null_pointer_node) ) @@ -16226,12 +16854,12 @@ parser_symbol_add(struct cbl_field_t *new_var ) { do { - fprintf(stderr, "( %d ) %s():", CURRENT_LINE_NUMBER, __func__); + fprintf(stderr, "( %d ) %s:", CURRENT_LINE_NUMBER, __func__); } while(0); - fprintf(stderr, " %2.2d %s<%s> off:" HOST_SIZE_T_PRINT_DEC " " - "msiz:%d cap:%d dig:%d rdig:%d attr:0x" HOST_SIZE_T_PRINT_HEX_PURE " loc:%p", + fprintf(stderr, " %2.2u %s<%s> off:" HOST_SIZE_T_PRINT_UNSIGNED " " + "msiz:%u cap:%u dig:%u rdig:%d attr:0x" HOST_SIZE_T_PRINT_HEX_PURE " loc:%p", new_var->level, new_var->name, cbl_field_type_str(new_var->type), @@ -16241,14 +16869,14 @@ parser_symbol_add(struct cbl_field_t *new_var ) new_var->data.digits, new_var->data.rdigits, (fmt_size_t)new_var->attr, - (void*)new_var); + static_cast<void*>(new_var)); if( is_table(new_var) ) { fprintf(stderr," OCCURS:" HOST_SIZE_T_PRINT_DEC, (fmt_size_t)new_var->occurs.ntimes()); } - cbl_field_t *parent = parent_of(new_var); + const cbl_field_t *parent = parent_of(new_var); if( parent ) { fprintf(stderr, @@ -16262,7 +16890,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) size_t parent_index = new_var->parent; if( parent_index ) { - symbol_elem_t *e = symbol_at(parent_index); + const symbol_elem_t *e = symbol_at(parent_index); if( e->type == SymFile ) { fprintf(stderr, @@ -16281,7 +16909,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) { fprintf(stderr, " redefines:(%p)%s", - (void*)symbol_redefines(new_var), + static_cast<void*>(symbol_redefines(new_var)), symbol_redefines(new_var)->name); } @@ -16364,7 +16992,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) // Make sure we have a new variable to work with. if( !new_var ) { - cbl_internal_error("parser_symbol_add() was called with a NULL new_var\n"); + cbl_internal_error("%<parser_symbol_add()%> was called with a NULL %<new_var%>"); } TRACE1 @@ -16381,10 +17009,12 @@ parser_symbol_add(struct cbl_field_t *new_var ) TRACE1_TEXT_ABC(" (", cbl_field_type_str(new_var->type) ,")") if( new_var->type == FldLiteralN) { + const void *p1 = (new_var->data.initial); + const long *pldata = static_cast<const long *>(p1); + long ldata = *pldata; gg_fprintf( trace_handle, 1, " [%ld]", - build_int_cst_type(LONG, - *(const long *)new_var->data.initial)); + build_int_cst_type(LONG, ldata)); } TRACE1_END } @@ -16392,7 +17022,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) if( is_table(new_var) && new_var->data.capacity == 0) { cbl_internal_error( - "%s(): %2.2d %s is a table, but it improperly has a capacity of zero", + "%s: %d %s is a table, but it improperly has a capacity of zero", __func__, new_var->level, new_var->name); @@ -16432,23 +17062,20 @@ parser_symbol_add(struct cbl_field_t *new_var ) if( ancestor == new_var ) { - cbl_internal_error("parser_symbol_add(): %s is its own ancestor", - new_var->name); + cbl_internal_error("%s: %s is its own ancestor", __func__, new_var->name); } if( !ancestor && (new_var->level > LEVEL01 && new_var->level <= LEVEL49 ) ) { - cbl_internal_error("parser_symbol_add(): %2.2d %s has null ancestor", - new_var->level, - new_var->name); + cbl_internal_error("%s: %d %qs has NULL ancestor", __func__, + new_var->level, new_var->name); } // new_var's var_decl_node should be NULL at this point if( new_var->var_decl_node ) { - cbl_internal_error( "parser_symbol_add( %s ) improperly has a non-null " - "var_decl_node\n", - new_var->name); + cbl_internal_error( "%s(%s) improperly has a non-null " + "%<var_decl_node%>", __func__, new_var->name); } switch( new_var->type ) @@ -16642,7 +17269,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) && new_var->type != FldLiteralN && new_var->type != FldLiteralA ) { - cbl_internal_error( "%s(): %2.2d %s<%s> improperly has a data.capacity of zero", + cbl_internal_error( "%s: %d %s<%s> improperly has a data.capacity of zero", __func__, new_var->level, new_var->name, @@ -16662,10 +17289,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) if( *external_record_base ) { char achDataName[256]; - if( *external_record_base ) - { - sprintf(achDataName, "__%s_vardata", external_record_base); - } + sprintf(achDataName, "__%s_vardata", external_record_base); tree array_type = build_array_type_nelts(UCHAR, new_var->data.capacity); new_var->data_decl_node = gg_define_variable( array_type, @@ -16712,12 +17336,10 @@ parser_symbol_add(struct cbl_field_t *new_var ) if( !bytes_to_allocate ) { - fprintf(stderr, - "bytes_to_allocate is zero for %s (symbol number " - HOST_SIZE_T_PRINT_DEC ")\n", - new_var->name, - (fmt_size_t)new_var->our_index); - gcc_assert(bytes_to_allocate); + cbl_internal_error( "%<bytes_to_allocate%> is zero for %s (symbol number " + HOST_SIZE_T_PRINT_DEC ")", + new_var->name, + (fmt_size_t)new_var->our_index); } if( new_var->type == FldIndex && new_var->level == 0 ) diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h index 2694457..b41b906 100644 --- a/gcc/cobol/genapi.h +++ b/gcc/cobol/genapi.h @@ -7,7 +7,7 @@ * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. - * * Redistributions in binary form must reproduce the above + * * Redistributions in binary form must reproduce the above` * copyright notice, this list of conditions and the following disclaimer * in the documentation and/or other materials provided with the * distribution. @@ -52,17 +52,26 @@ void parser_division( cbl_division_t division, void parser_enter_program(const char *funcname, bool is_function, int *retval); void parser_leave_program(); -void parser_accept( cbl_refer_t refer, special_name_t special_e); +void parser_accept( const cbl_refer_t &refer, + special_name_t special_e, + cbl_label_t *error, + cbl_label_t *not_error ); void parser_accept_exception( cbl_label_t *name ); void parser_accept_exception_end( cbl_label_t *name ); -void parser_accept_envar( cbl_refer_t refer, cbl_refer_t envar, - cbl_label_t *error, cbl_label_t *not_error ); -void parser_set_envar( cbl_refer_t envar, cbl_refer_t refer ); +void parser_accept_under_discussion(struct cbl_refer_t tgt, special_name_t special, + cbl_label_t *error, cbl_label_t *not_error ); +void parser_accept_envar( const cbl_refer_t &refer, + const cbl_refer_t &envar, + cbl_label_t *error, + cbl_label_t *not_error ); +void parser_set_envar( const cbl_refer_t &envar, const cbl_refer_t &refer ); -void parser_accept_command_line( cbl_refer_t tgt, cbl_refer_t src, - cbl_label_t *error, cbl_label_t *not_error ); -void parser_accept_command_line_count( cbl_refer_t tgt ); +void parser_accept_command_line(const cbl_refer_t &tgt, + const cbl_refer_t &src, + cbl_label_t *error, + cbl_label_t *not_error ); +void parser_accept_command_line_count( const cbl_refer_t &tgt ); void parser_accept_date_yymmdd( cbl_field_t *tgt ); void parser_accept_date_yyyymmdd( cbl_field_t *tgt ); @@ -86,8 +95,7 @@ parser_add( size_t nC, cbl_num_result_t *C, size_t nA, cbl_refer_t *A, cbl_arith_format_t format, cbl_label_t *error, - cbl_label_t *not_error, - void *compute_error = NULL); // This has to be cast to a tree pointer to int + cbl_label_t *not_error, void *compute_error = NULL); // This has to be cast to a tree pointer to int void parser_arith_error( cbl_label_t *name ); void parser_arith_error_end( cbl_label_t *name ); @@ -119,26 +127,26 @@ parser_divide(size_t nC, cbl_num_result_t *C, void *compute_error = NULL); // This has to be cast to a tree pointer to int void -parser_add( struct cbl_refer_t tgt, - struct cbl_refer_t a, struct cbl_refer_t b, +parser_add( const cbl_refer_t& tgt, + const cbl_refer_t& a, const cbl_refer_t& b, enum cbl_round_t = truncation_e ); void -parser_subtract( struct cbl_refer_t tgt, - struct cbl_refer_t a, struct cbl_refer_t b, +parser_subtract( const cbl_refer_t& tgt, + const cbl_refer_t& a, const cbl_refer_t& b, enum cbl_round_t = truncation_e ); void -parser_multiply( struct cbl_refer_t tgt, - struct cbl_refer_t a, struct cbl_refer_t b, +parser_multiply( const cbl_refer_t& tgt, + const cbl_refer_t& a, const cbl_refer_t& b, enum cbl_round_t = truncation_e ); void -parser_divide( struct cbl_refer_t quotient, - struct cbl_refer_t divisor, - struct cbl_refer_t dividend, +parser_divide( const cbl_refer_t& quotient, + const cbl_refer_t& divisor, + const cbl_refer_t& dividend, enum cbl_round_t = truncation_e, - struct cbl_refer_t remainder = cbl_refer_t()); + const cbl_refer_t& remainder = cbl_refer_t()); // void // parser_exponentiation( cbl_refer_t cref, @@ -174,7 +182,8 @@ parser_bitwise_op(struct cbl_field_t *tgt, void parser_classify( struct cbl_field_t *tgt, - struct cbl_refer_t srca, enum classify_t type ); + const struct cbl_refer_t &srca, + enum classify_t type ); void parser_op( struct cbl_refer_t cref, @@ -225,7 +234,7 @@ parser_perform_conditional_end( struct cbl_perform_tgt_t *tgt ); * For an in-line loop body, tgt->from.type == LblLoop, and tgt->to is NULL. */ void -parser_perform( struct cbl_perform_tgt_t *tgt, struct cbl_refer_t N ); +parser_perform( const cbl_perform_tgt_t *tgt, cbl_refer_t N ); /* * A simple UNTIL loop uses 1 varys element. For VARY loops, the @@ -253,18 +262,23 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ); void parser_end_program(const char *name=NULL); -void parser_sleep(cbl_refer_t seconds); +void parser_sleep(const cbl_refer_t &seconds); -void parser_exit( cbl_refer_t refer, ec_type_t = ec_none_e ); +void parser_exit( const cbl_refer_t& refer, ec_type_t = ec_none_e ); void parser_exit_section(void); void parser_exit_paragraph(void); void parser_exit_perform( struct cbl_perform_tgt_t *tgt, bool cycle ); void parser_exit_program(void); // exits back to COBOL only, else continue void +parser_exhibit( bool changed, bool named, + const std::vector<cbl_refer_t> &args ); +void parser_display( const struct cbl_special_name_t *upon, - struct cbl_refer_t args[], size_t n, - bool advance = DISPLAY_ADVANCE ); + const std::vector<cbl_refer_t> &args, + bool advance = DISPLAY_ADVANCE, + const cbl_label_t *not_error = nullptr, + const cbl_label_t *compute_error = nullptr ); void parser_display_field(cbl_field_t *fld); @@ -297,10 +311,10 @@ void parser_symbol_add(struct cbl_field_t *field); void -parser_initialize(struct cbl_refer_t refer, bool like_parser_symbol_add=false); +parser_initialize(const cbl_refer_t& refer, bool like_parser_symbol_add=false); void -parser_initialize_programs(size_t nprog, struct cbl_refer_t *progs); +parser_initialize_programs(size_t nprog, const struct cbl_refer_t *progs); void parser_label_label( struct cbl_label_t *label ); @@ -315,7 +329,7 @@ void parser_alter( cbl_perform_tgt_t *tgt ); void -parser_set_conditional88( struct cbl_refer_t tgt, bool which_way ); +parser_set_conditional88( const cbl_refer_t& tgt, bool which_way ); void parser_set_numeric(struct cbl_field_t *tgt, ssize_t value); @@ -406,14 +420,12 @@ void parser_sort(cbl_refer_t table, bool duplicates, cbl_alphabet_t *alphabet, - size_t nkey, - cbl_key_t *keys ); + const std::vector<cbl_key_t>& keys ); void parser_file_sort( cbl_file_t *file, bool duplicates, cbl_alphabet_t *alphabet, - size_t nkey, - cbl_key_t *keys, + const std::vector<cbl_key_t>& keys, size_t ninput, cbl_file_t **inputs, size_t noutput, @@ -423,8 +435,7 @@ parser_file_sort( cbl_file_t *file, void parser_file_merge( cbl_file_t *file, cbl_alphabet_t *alphabet, - size_t nkey, - cbl_key_t *keys, + const std::vector<cbl_key_t>& keys, size_t ninput, cbl_file_t **inputs, size_t noutput, @@ -450,7 +461,7 @@ parser_intrinsic_numval_c( cbl_field_t *f, void parser_intrinsic_subst( cbl_field_t *f, - cbl_refer_t& ref1, + const cbl_refer_t& ref1, size_t argc, cbl_substitute_t * argv ); @@ -492,12 +503,12 @@ void parser_string_overflow_end( cbl_label_t *name ); void -parser_string( cbl_refer_t tgt, - cbl_refer_t pointer, - size_t nsource, - cbl_string_src_t *sources, - cbl_label_t *overflow, - cbl_label_t *not_overflow ); +parser_string(const cbl_refer_t& tgt, + const cbl_refer_t& pointer, + size_t nsource, + cbl_string_src_t *sources, + cbl_label_t *overflow, + cbl_label_t *not_overflow ); void parser_unstring( cbl_refer_t src, @@ -552,7 +563,7 @@ void parser_entry_activate( size_t iprog, const cbl_label_t *declarative ); void parser_entry( cbl_field_t *name, size_t narg = 0, cbl_ffi_arg_t args[] = NULL); -bool is_ascending_key(cbl_refer_t key); +bool is_ascending_key(const cbl_refer_t& key); void register_main_switch(const char *main_string); diff --git a/gcc/cobol/gengen.cc b/gcc/cobol/gengen.cc index 91f67d5..3ad3344 100644 --- a/gcc/cobol/gengen.cc +++ b/gcc/cobol/gengen.cc @@ -107,8 +107,6 @@ // Don't like it? Cry me a river. static const int ARG_LIMIT = 512; -static int sv_current_line_number; - // These are globally useful constants tree char_nodes[256]; @@ -136,6 +134,14 @@ tree bool_false_node; struct cbl_translation_unit_t gg_trans_unit; +// This set is used to prevent duplicated top-level program names from breaking +// the compiler when a source code module makes that mistake. +static std::unordered_set<std::string> names_we_have_seen; + +// This vector is used to process the function_decls at the point we leave +// the file. +static std::vector<tree> finalized_function_decls; + void gg_build_translation_unit(const char *filename) { @@ -257,14 +263,6 @@ gg_append_var_decl(tree var_decl) } } -location_t -location_from_lineno() - { - location_t loc; - loc = linemap_line_start(line_table, sv_current_line_number, 0); - return loc; - } - void gg_append_statement(tree stmt) { @@ -354,13 +352,12 @@ adjust_for_type(tree type) return retval; } -static char * -show_type(tree type) +gg_show_type(tree type) { if( !type ) { - cbl_internal_error("The given type is not NULL, and that's just not fair"); + cbl_internal_error("The given type is NULL, and that is just not fair"); } if( DECL_P(type) ) @@ -369,14 +366,17 @@ show_type(tree type) } if( !TYPE_P(type) ) { - cbl_internal_error("The given type is not a DECL or a TYPE"); + cbl_internal_error("The given type is not a declaration or a TYPE"); } - static char ach[1024]; + static char ach[1100]; + static char ach2[1024]; + static char ach3[1024]; switch( TREE_CODE(type) ) { case POINTER_TYPE: - sprintf(ach, "POINTER"); + strcpy(ach2, gg_show_type(TREE_TYPE(type))); + sprintf(ach, "POINTER to %s", ach2); break; case VOID_TYPE: @@ -405,11 +405,8 @@ show_type(tree type) break; case FUNCTION_TYPE: - sprintf(ach, "FUNCTION"); -// sprintf(ach, -// "%3ld-bit %s INT", -// TREE_INT_CST_LOW(TYPE_SIZE(type)), -// (TYPE_UNSIGNED(type) ? "unsigned" : " signed")); + strcpy(ach3, gg_show_type(TREE_TYPE(type))); + sprintf(ach, "FUNCTION returning %s", ach3); break; default: @@ -419,7 +416,7 @@ show_type(tree type) return ach; } -void +tree gg_assign(tree dest, const tree source) { // This does the equivalent of a C/C++ "dest = source". When X1 is set, it @@ -430,6 +427,7 @@ gg_assign(tree dest, const tree source) // This routine also provides for the possibility that the assignment is // for a source that is a function invocation, as in // "dest = function_call()" + tree stmt = NULL_TREE; saw_pointer = false; tree dest_type = adjust_for_type(TREE_TYPE(dest)); @@ -452,11 +450,11 @@ gg_assign(tree dest, const tree source) if( okay ) { - tree stmt = build2_loc( location_from_lineno(), - MODIFY_EXPR, - TREE_TYPE(dest), - dest, - source); + stmt = build2_loc(gg_token_location(), + MODIFY_EXPR, + TREE_TYPE(dest), + dest, + source); gg_append_statement(stmt); } else @@ -465,20 +463,25 @@ gg_assign(tree dest, const tree source) // the same. This is a compilation-time error, since we want the caller to // have sorted the types out explicitly. If we don't throw an error here, // the gimple reduction will do so. Better to do it here, when we know - // where we are. - dbgmsg("Inefficient assignment"); - if(DECL_P(dest) && DECL_NAME(dest)) - { - dbgmsg(" Destination is %s", IDENTIFIER_POINTER(DECL_NAME(dest))); - } - dbgmsg(" dest type is %s%s", show_type(dest_type), p2 ? "_P" : ""); - if(DECL_P(source) && DECL_NAME(source)) + // where we are.S + static const int debugging = 1; + if( debugging ) { - dbgmsg(" Source is %s", IDENTIFIER_POINTER(DECL_NAME(source))); + fprintf(stderr, "Inefficient assignment\n"); + if(DECL_P(dest) && DECL_NAME(dest)) + { + fprintf(stderr, " Destination is %s\n", IDENTIFIER_POINTER(DECL_NAME(dest))); + } + fprintf(stderr, " dest type is %s%s\n", gg_show_type(dest_type), p2 ? "_P" : ""); + if(DECL_P(source) && DECL_NAME(source)) + { + fprintf(stderr, " Source is %s\n", IDENTIFIER_POINTER(DECL_NAME(source))); + } + fprintf(stderr, " source type is %s%s\n", gg_show_type(source_type), p2 ? "_P" : ""); } - dbgmsg(" source type is %s%s", show_type(source_type), p2 ? "_P" : ""); - gcc_unreachable(); + cbl_internal_error("Attempting an assignment of differing types."); } + return stmt; } tree @@ -520,8 +523,7 @@ gg_find_field_in_struct(const tree base, const char *field_name) if( !field_decl ) { - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); - yywarn("###### Somebody asked for the field %s.%s, which doesn't exist", + yywarn("Somebody asked for the field %s.%s, which does not exist", IDENTIFIER_POINTER(DECL_NAME(base)), field_name); gcc_unreachable(); @@ -612,7 +614,7 @@ gg_add_field_to_structure(const tree type_of_field, const char *name_of_field, t tree id_of_field = get_identifier (name_of_field); // Create the new field: - tree new_field_decl = build_decl( location_from_lineno(), + tree new_field_decl = build_decl( gg_token_location(), FIELD_DECL, id_of_field, type_of_field); @@ -889,7 +891,7 @@ gg_create_assembler_name(const char *cobol_name) static char * gg_unique_in_function(const char *var_name, gg_variable_scope_t vs_scope) { - char *retval = (char *)xmalloc(strlen(var_name)+32); + char *retval = static_cast<char *>(xmalloc(strlen(var_name)+32)); if( (vs_scope == vs_stack || vs_scope == vs_static) ) { sprintf(retval, "%s." HOST_SIZE_T_PRINT_DEC, var_name, @@ -933,7 +935,7 @@ gg_declare_variable(tree type_decl, // causes the storage to be allocated. // It is routine to let the compiler assign names to stack variables. The - // assembly code doesn't use names for variables on the stack; they are + // assembly code does not use names for variables on the stack; they are // referenced by offsets to the base pointer. But static variables have to // have names, and there are places in my code generation -- Lord only knows // why -- where I didn't give the variables explicit names. We remedy that @@ -1024,10 +1026,7 @@ gg_declare_variable(tree type_decl, break; } DECL_INITIAL(var_decl) = initial_value; - if( unique_name ) - { - free(unique_name); - } + free(unique_name); return var_decl; } @@ -1042,7 +1041,7 @@ gg_define_from_declaration(tree var_decl) { // Having made sure the chain of variable declarations is nicely started, // it's time to actually define the storage with a decl_expression: - tree stmt = build1_loc (location_from_lineno(), + tree stmt = build1_loc (gg_token_location(), DECL_EXPR, TREE_TYPE(var_decl), var_decl); @@ -1773,7 +1772,7 @@ gg_build_relational_expression(tree operand_a, compare = LE_EXPR; break; } - tree relational_expression = build2_loc(location_from_lineno(), + tree relational_expression = build2_loc(gg_token_location(), compare, boolean_type_node, operand_a, @@ -1890,7 +1889,7 @@ gg_create_goto_pair(tree *goto_expr, void gg_goto_label_decl(tree label_decl) { - tree goto_expr = build1_loc( location_from_lineno(), + tree goto_expr = build1_loc( gg_token_location(), GOTO_EXPR, void_type_node, label_decl); @@ -1937,7 +1936,7 @@ gg_create_goto_pair(tree *goto_expr, tree *label_expr, const char *name) void gg_goto(tree var_decl_pointer) { - tree go_to = build1_loc(location_from_lineno(), + tree go_to = build1_loc(gg_token_location(), GOTO_EXPR, void_type_node, var_decl_pointer); @@ -2152,18 +2151,6 @@ gg_printf(const char *format_string, ...) int nargs = 0; tree args[ARG_LIMIT]; - // Because this routine is intended for debugging, we are sending the - // text to STDERR - - // Because we don't actually use stderr ourselves, we just pick it up as a - // VOID_P and pass it along to fprintf() - tree t_stderr = gg_declare_variable(VOID_P, "stderr", - NULL_TREE, - vs_external_reference); - - gg_push_context(); - - args[nargs++] = t_stderr; args[nargs++] = build_string_literal(strlen(format_string)+1, format_string); va_list ap; @@ -2173,8 +2160,7 @@ gg_printf(const char *format_string, ...) { if(nargs >= ARG_LIMIT) { - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); - yywarn("###### You *must* be joking!"); + yywarn("You *must* be joking"); gcc_unreachable(); } @@ -2182,10 +2168,8 @@ gg_printf(const char *format_string, ...) { // Warning: This test is not completely reliable, because a garbage // byte could have a valid TREE_CODE. But it does help. - yywarn("You nitwit!"); - yywarn("You forgot to put a NULL_TREE at the end of a " - "gg_printf() again!"); - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); + yywarn("You forgot to put a %<NULL_TREE%> at the end of a " + "%<gg_printf()%> again"); gcc_unreachable(); } @@ -2197,17 +2181,15 @@ gg_printf(const char *format_string, ...) static tree function = NULL_TREE; if( !function ) { - function = gg_get_function_address(INT, "fprintf"); + function = gg_get_function_address(INT, "__gg__fprintf_stderr"); } - tree stmt = build_call_array_loc (location_from_lineno(), + tree stmt = build_call_array_loc (gg_token_location(), INT, function, nargs, args); gg_append_statement(stmt); - - gg_pop_context(); } tree @@ -2233,8 +2215,7 @@ gg_fprintf(tree fd, int nargs, const char *format_string, ...) { if(argc >= ARG_LIMIT) { - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); - yywarn("###### You *must* be joking!"); + yywarn("You *must* be joking"); gcc_unreachable(); } @@ -2250,7 +2231,7 @@ gg_fprintf(tree fd, int nargs, const char *format_string, ...) function = gg_get_function_address(INT, "sprintf"); } - tree stmt = build_call_array_loc (location_from_lineno(), + tree stmt = build_call_array_loc (gg_token_location(), INT, function, argc, @@ -2297,7 +2278,7 @@ void gg_memset(tree dest, const tree value, tree size) { tree the_call = - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_MEMSET), 3, dest, @@ -2311,7 +2292,7 @@ gg_memchr(tree buf, tree ch, tree length) { tree the_call = fold_convert( pvoid_type_node, - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_MEMCHR), 3, buf, @@ -2326,7 +2307,7 @@ void gg_memcpy(tree dest, const tree src, tree size) { tree the_call = build_call_expr_loc( - location_from_lineno(), + gg_token_location(), builtin_decl_explicit (BUILT_IN_MEMCPY), 3, dest, @@ -2341,7 +2322,7 @@ void gg_memmove(tree dest, const tree src, tree size) { tree the_call = build_call_expr_loc( - location_from_lineno(), + gg_token_location(), builtin_decl_explicit (BUILT_IN_MEMMOVE), 3, dest, @@ -2374,7 +2355,7 @@ void gg_strcpy(tree dest, tree src) { tree the_call = - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_STRCPY), 2, dest, @@ -2387,7 +2368,7 @@ gg_strcmp(tree A, tree B) { tree the_call = fold_convert( integer_type_node, - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_STRCMP), 2, A, @@ -2419,7 +2400,7 @@ gg_strncmp(tree char_star_A, tree char_star_B, tree size_t_N) { tree the_call = fold_convert( integer_type_node, - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_STRNCMP), 3, char_star_A, @@ -2450,7 +2431,7 @@ gg_return(tree operand) { // When there is no operand, or if the function result is void, then // we just generate a return_expr. - stmt = build1_loc(location_from_lineno(), RETURN_EXPR, void_type_node, NULL_TREE); + stmt = build1_loc(gg_token_location(), RETURN_EXPR, void_type_node, NULL_TREE); } else { @@ -2460,7 +2441,7 @@ gg_return(tree operand) function_type, DECL_RESULT(current_function->function_decl), gg_cast(function_type, operand)); - stmt = build1_loc(location_from_lineno(), RETURN_EXPR, void_type_node, modify); + stmt = build1_loc(gg_token_location(), RETURN_EXPR, void_type_node, modify); } gg_append_statement(stmt); } @@ -2468,7 +2449,7 @@ gg_return(tree operand) void chain_parameter_to_function(tree function_decl, const tree param_type, const char *name) { - tree parm = build_decl (location_from_lineno(), + tree parm = build_decl (gg_token_location(), PARM_DECL, get_identifier (name), param_type); @@ -2486,171 +2467,113 @@ chain_parameter_to_function(tree function_decl, const tree param_type, const ch } } -void -gg_modify_function_type(tree function_decl, tree return_type) - { - tree fndecl_type = build_varargs_function_type_array( return_type, - 0, // No parameters yet - NULL); // And, hence, no types - TREE_TYPE(function_decl) = fndecl_type; - tree resdecl = build_decl (UNKNOWN_LOCATION, RESULT_DECL, NULL_TREE, return_type); - DECL_CONTEXT (resdecl) = function_decl; - DECL_RESULT (function_decl) = resdecl; - } +/* There are five ways that we use function_decls: -tree -gg_define_function_with_no_parameters(tree return_type, - const char *funcname, - const char *unmangled_name) - { - // This routine builds a function_decl, puts it on the stack, and - // gives it a context. + 1, We define a main() entry point. + 2. We call a function that turns out to be a static "t" function local to the source code module. + 3. We define an global "T" function, and possibly call it later. + 4. We call a function that we define later in the source code module. + 5. We call a function that ends up being an extern that is not defined in the source code module. - // At this time we don't know how many parameters this function expects, so - // we set things up and we'll tack on the parameters later. + Cases 3. and 4. turn out to require the same flags. Here are the combinations of + flags that are required for each flavor of function_decl. This was empirically + determind by compiling a C++ program with sample code for each type. - // Create the FUNCTION_TYPE for that array: - // int nparams = 1; - // tree types[1] = {VOID_P}; - // const char *names[1] = {"_p1"}; + | addressable | used | nothrow | static | external | public | no_instrument +main | | | | X | | X | X +local | X | X | X | X | | | X +external defined inside | X | X | X | X | | X | X +external defined elsewhere | X | X | | | X | X | - // tree fndecl_type = build_varargs_function_type_array( return_type, - // nparams, - // types); +*/ - tree fndecl_type = build_varargs_function_type_array( return_type, - 0, // No parameters yet - NULL); // And, hence, no types - - // Create the FUNCTION_DECL for that FUNCTION_TYPE - tree function_decl = build_fn_decl (funcname, fndecl_type); - // Some of this stuff is magical, and is based on compiling C programs - // and just mimicking the results. - TREE_ADDRESSABLE(function_decl) = 1; - TREE_STATIC(function_decl) = 1; - DECL_EXTERNAL (function_decl) = 0; - DECL_PRESERVE_P (function_decl) = 0; - DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 1; - DECL_ARTIFICIAL(function_decl) = 0; - TREE_NOTHROW(function_decl) = 0; - TREE_USED(function_decl) = 1; +static std::unordered_map<std::string, tree> map_of_function_decls; - // This code makes COBOL nested programs actual visible on the - // source code "trans_unit_decl" level, but with non-public "static" - // visibility. - if( gg_trans_unit.function_stack.size() == 0 ) - { - // gg_trans_unit.function_stack is empty, so our context is - // the compilation module, and we need to be public: - DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl; - TREE_PUBLIC(function_decl) = 1; - } - else - { - // The stack has something in it, so we are building a nested function. - // Make the current function our context - DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl; - TREE_PUBLIC(function_decl) = 0; +static +std::string function_decl_key(const char *funcname, tree fndecl_type) + { + std::string retval; + retval += funcname; + retval += gg_show_type(TREE_TYPE(fndecl_type)); + return retval; + } - // This function is file static, but nobody calls it, so without - // intervention -O1+ optimizations will discard it. - DECL_PRESERVE_P (function_decl) = 1; +tree +gg_peek_fn_decl(const char *funcname, tree fndecl_type) + { + // When funcname is found in map_of_function_decls, this routine returns + // the type of the return value of that function decl. - // Append this function to the list of functions and variables - // associated with the computation module. - gg_append_var_decl(function_decl); + tree retval = NULL_TREE; + std::string key = function_decl_key(funcname, fndecl_type); + std::unordered_map<std::string, tree>::const_iterator it = + map_of_function_decls.find(key); + if( it != map_of_function_decls.end() ) + { + // This function_decl has already been defined. + retval = TREE_TYPE(TREE_TYPE(it->second)); } - - // Establish the RESULT_DECL for the function: - tree resdecl = build_decl (location_from_lineno(), RESULT_DECL, NULL_TREE, return_type); - DECL_CONTEXT (resdecl) = function_decl; - DECL_RESULT (function_decl) = resdecl; - - // The function_decl has a .function member, a pointer to struct_function. - // This is quietly, almost invisibly, extremely important. You need to - // call this routine after DECL_RESULT has been established: - - allocate_struct_function(function_decl, false); - - struct gg_function_t new_function = {}; - new_function.context_count = 0; - new_function.function_decl = function_decl; - new_function.our_name = IDENTIFIER_POINTER(DECL_NAME(function_decl)); - new_function.our_unmangled_name = xstrdup(unmangled_name); - new_function.function_address = gg_get_function_address(VOID, new_function.our_name); - - // Each program on the stack gets a unique identifier. This is used, for - // example, to make sure that static variables have unique names. - static size_t program_id = 0; - new_function.program_id_number = program_id++; - - // With everything established, put this function_decl on the stack - gg_trans_unit.function_stack.push_back(new_function); - - // All we need is a context, and we are ready to go: - gg_push_context(); - return function_decl; + return retval; } -void -gg_tack_on_function_parameters(tree function_decl, ...) +tree +gg_build_fn_decl(const char *funcname, tree fndecl_type) { - int nparams = 0; - - tree types[ARG_LIMIT]; - const char *names[ARG_LIMIT]; + tree function_decl; - va_list params; - va_start(params, function_decl); - for(;;) + std::string key = function_decl_key(funcname, fndecl_type); + std::unordered_map<std::string, tree>::const_iterator it = + map_of_function_decls.find(key); + if( it != map_of_function_decls.end() ) { - tree var_type = va_arg(params, tree); - if( !var_type ) - { - break; - } - - if( TREE_CODE(var_type) >= NUM_TREE_CODES) - { - // Warning: This test is not completely reliable, because a garbage - // byte could have a valid TREE_CODE. But it does help. - yywarn("You nitwit!"); - yywarn("You forgot to put a NULL_TREE at the end of a " - "gg_define_function() again!"); - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); - gcc_unreachable(); - } + // This function_decl has already been defined. Just return it; the caller + // is responsible for modifying it, if necessary. + function_decl = it->second; + } + else + { + // When creating a never-seen function_decl, we default to the type used + // for calling a function defined elsewhere. It's up to our caller to + // modify the flags, for example if this is part of creating a function. - const char *name = va_arg(params, const char *); + function_decl = build_fn_decl(funcname, fndecl_type); - types[nparams] = var_type; - names[nparams] = name; - nparams += 1; - if(nparams > ARG_LIMIT) - { - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); - yywarn("###### %d parameters? Really? Are you insane?",ARG_LIMIT+1); - gcc_unreachable(); - } - } - va_end(params); + // These are the bits shown in the table in the comment up above + TREE_ADDRESSABLE(function_decl) = 1; + TREE_USED(function_decl) = 1; + TREE_NOTHROW(function_decl) = 0; + TREE_STATIC(function_decl) = 0; + DECL_EXTERNAL (function_decl) = 1; + TREE_PUBLIC (function_decl) = 1; + DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 0; - // Chain the names onto the variables list: - for(int i=0; i<nparams; i++) - { - chain_parameter_to_function(function_decl, types[i], names[i]); + DECL_PRESERVE_P (function_decl) = 0; + DECL_ARTIFICIAL(function_decl) = 0; + map_of_function_decls[key] = function_decl; } + return function_decl; } -void -gg_define_function(tree return_type, const char *funcname, ...) +tree +gg_define_function( tree return_type, + const char *funcname, + const char *unmangled_name, + ...) { // This routine builds a function_decl, puts it on the stack, and // gives it a context. - // After the funcname, we expect the formal parameters: pairs of types/names - // terminated by a NULL_TREE + // At this time we don't know how many parameters this function expects, so + // we set things up and we'll tack on the parameters later. + + /* There is some bookkeeping we need to do to avoid crashing. + + It's possible for the source code to have two top-level functions with + the same name. This is a compile-time error, but the GCC processing gets + upset when it happens. We'll prevent it from happening here: + + */ int nparams = 0; @@ -2658,7 +2581,7 @@ gg_define_function(tree return_type, const char *funcname, ...) const char *names[ARG_LIMIT]; va_list params; - va_start(params,funcname); + va_start(params, unmangled_name); for(;;) { tree var_type = va_arg(params, tree); @@ -2671,10 +2594,8 @@ gg_define_function(tree return_type, const char *funcname, ...) { // Warning: This test is not completely reliable, because a garbage // byte could have a valid TREE_CODE. But it does help. - yywarn("You nitwit!"); - yywarn("You forgot to put a NULL_TREE at the end of a " - "gg_define_function() again!"); - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); + yywarn("You forgot to put a %<NULL_TREE%> at the end of a " + "%<gg_define_function()%> again"); gcc_unreachable(); } @@ -2685,32 +2606,33 @@ gg_define_function(tree return_type, const char *funcname, ...) nparams += 1; if(nparams > ARG_LIMIT) { - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); - yywarn("###### %d parameters? Really? Are you insane?", - ARG_LIMIT+1); + yywarn("%d parameters? Really? Are you insane?", ARG_LIMIT+1); gcc_unreachable(); } } va_end(params); - // Create the FUNCTION_TYPE for that array: + char ach[32]; + std::unordered_set<std::string>::const_iterator it = + names_we_have_seen.find(funcname); + if( it != names_we_have_seen.end() ) + { + static int bum_counter = 1; + // We have seen this name before. Replace it with something unique: + sprintf(ach, "..no_dupes.%d", bum_counter++); + funcname = ach; + } + else + { + names_we_have_seen.insert(funcname); + } + tree fndecl_type = build_varargs_function_type_array( return_type, nparams, types); // Create the FUNCTION_DECL for that FUNCTION_TYPE - tree function_decl = build_fn_decl (funcname, fndecl_type); - - // Some of this stuff is magical, and is based on compiling C programs - // and just mimicking the results. - TREE_ADDRESSABLE(function_decl) = 1; - TREE_STATIC(function_decl) = 1; - DECL_EXTERNAL (function_decl) = 0; - DECL_PRESERVE_P (function_decl) = 0; - DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 1; - DECL_ARTIFICIAL(function_decl) = 0; - TREE_NOTHROW(function_decl) = 0; - TREE_USED(function_decl) = 1; + tree function_decl = gg_build_fn_decl (funcname, fndecl_type); // This code makes COBOL nested programs actual visible on the // source code "trans_unit_decl" level, but with non-public "static" @@ -2718,22 +2640,40 @@ gg_define_function(tree return_type, const char *funcname, ...) if( gg_trans_unit.function_stack.size() == 0 ) { // gg_trans_unit.function_stack is empty, so our context is - // the compilation module, and we need to be public: + // the compilation module, and we need to be public because this is a + // top-level function with global scope: + + // These are the bits shown in the table for gg_build_fn_decl() + TREE_ADDRESSABLE(function_decl) = 1; + TREE_USED(function_decl) = 1; + TREE_NOTHROW(function_decl) = 1; + TREE_STATIC(function_decl) = 1; + DECL_EXTERNAL (function_decl) = 0; + TREE_PUBLIC (function_decl) = 1; + DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 1; DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl; - TREE_PUBLIC(function_decl) = 1; } else { - // The stack has something in it, so we are building a nested function. - // Make the current function our context + // The stack has something in it, so we are building a contained + // program-id. Such function are implemented local static functions. + // + // It's not necessarily true that a static call to such a function will be + // part of the source code (the call can be through a variable), and so + // optimization routines can decide the function isn't used and can + // therefore be optimized away. The preserve flag prevents that. + + // These are the bits shown in the table for gg_build_fn_decl() + TREE_ADDRESSABLE(function_decl) = 1; + TREE_USED(function_decl) = 1; + TREE_NOTHROW(function_decl) = 1; + TREE_STATIC(function_decl) = 1; + DECL_EXTERNAL (function_decl) = 0; + TREE_PUBLIC (function_decl) = 0; + DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 1; DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl; - - // We need to make it public, because otherwise COBOL CALL "func" - // won't be able to find it, because dlopen/dlsym won't find it. - TREE_PUBLIC(function_decl) = 0; - - // Append this function to the list of functions and variables - // associated with the computation module. + DECL_CONTEXT(function_decl) = gg_trans_unit.trans_unit_decl; + DECL_PRESERVE_P (function_decl) = 1; gg_append_var_decl(function_decl); } @@ -2744,7 +2684,7 @@ gg_define_function(tree return_type, const char *funcname, ...) } // Establish the RESULT_DECL for the function: - tree resdecl = build_decl (location_from_lineno(), RESULT_DECL, NULL_TREE, return_type); + tree resdecl = build_decl (gg_token_location(), RESULT_DECL, NULL_TREE, return_type); DECL_CONTEXT (resdecl) = function_decl; DECL_RESULT (function_decl) = resdecl; @@ -2757,6 +2697,9 @@ gg_define_function(tree return_type, const char *funcname, ...) struct gg_function_t new_function = {}; new_function.context_count = 0; new_function.function_decl = function_decl; + new_function.our_name = IDENTIFIER_POINTER(DECL_NAME(function_decl)); + new_function.our_unmangled_name = xstrdup(unmangled_name); + new_function.function_address = gg_get_address_of(function_decl); // Each program on the stack gets a unique identifier. This is used, for // example, to make sure that static variables have unique names. @@ -2768,6 +2711,19 @@ gg_define_function(tree return_type, const char *funcname, ...) // All we need is a context, and we are ready to go: gg_push_context(); + return function_decl; + } + +void +gg_modify_function_type(tree function_decl, tree return_type) + { + tree fndecl_type = build_varargs_function_type_array( return_type, + 0, // No parameters yet + NULL); // And, hence, no types + TREE_TYPE(function_decl) = fndecl_type; + tree resdecl = build_decl (UNKNOWN_LOCATION, RESULT_DECL, NULL_TREE, return_type); + DECL_CONTEXT (resdecl) = function_decl; + DECL_RESULT (function_decl) = resdecl; } tree @@ -2799,10 +2755,8 @@ gg_get_function_decl(tree return_type, const char *funcname, ...) { // Warning: This test is not completely reliable, because a garbage // byte could have a valid TREE_CODE. But it does help. - yywarn("You nitwit!"); - yywarn("You forgot to put a NULL_TREE at the end of a " - "gg_define_function() again!"); - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); + yywarn("You forgot to put a %<NULL_TREE%> at the end of a " + "%<gg_define_function()%> again"); gcc_unreachable(); } @@ -2813,8 +2767,7 @@ gg_get_function_decl(tree return_type, const char *funcname, ...) nparams += 1; if(nparams > ARG_LIMIT) { - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); - yywarn("###### %d parameters? Really? Are you insane?", + yywarn("%d parameters? Really? Are you insane?", ARG_LIMIT+1); gcc_unreachable(); } @@ -2863,7 +2816,7 @@ gg_get_function_decl(tree return_type, const char *funcname, ...) } // Establish the RESULT_DECL for the function: - tree resdecl = build_decl (location_from_lineno(), RESULT_DECL, NULL_TREE, return_type); + tree resdecl = build_decl (gg_token_location(), RESULT_DECL, NULL_TREE, return_type); DECL_CONTEXT (resdecl) = function_decl; DECL_RESULT (function_decl) = resdecl; @@ -2889,63 +2842,73 @@ gg_finalize_function() // Finish off the context gg_pop_context(); - if( gg_trans_unit.function_stack.back().is_truly_nested ) - { - // This code is for true nested functions. - - ///////// DANGER, WILL ROBINSON! - ///////// This is all well and good. It does not, however, work. - ///////// I tried to implement it because I had a Brilliant Idea for - ///////// building COBOL paragraphs in a way that would easily allow - ///////// the GDB "NEXT" command to step over a PERFORM <paragraph>. - ///////// But, alas, I realized that it was just not going to work. - ///////// - ///////// Pity. - ///////// - ///////// But at that point, I was here, and I am leaving this uncooked - ///////// code in case I someday want to return to it. If it becomes - ///////// your job, rather than mine, I encourage you to write a C - ///////// program that uses the GNU extensions that allow true nested - ///////// functions, and reverse engineer the "finish_function" - ///////// function, and get it working. - ///////// - ///////// Good luck. Bob Dubner, 2022-08-13 - - // Because this is a nested function, let's make sure that it actually - // has a function that it is nested within - gcc_assert(gg_trans_unit.function_stack.size() > 1 ); - - /* Genericize before inlining. Delay genericizing nested functions - until their parent function is genericized. Since finalizing - requires GENERIC, delay that as well. */ - - // This is the comment in gcc/c/c-decl.c: - - /* Register this function with cgraph just far enough to get it - added to our parent's nested function list. Handy, since the - C front end doesn't have such a list. */ - - static cgraph_node *node = cgraph_node::get_create (current_function->function_decl); - gcc_assert(node); - - } - else - { - // This makes the function visible on the source code module level. - cgraph_node::finalize_function (current_function->function_decl, true); - } + /* Because COBOL functions can be misleadingly referenced before they + defined, and because our compiler is single pass, we need to defer + actually passing the function_decls to the middle end until we are + done with the entire compilation unit. + + An actual example: + + IDENTIFICATION DIVISION. + PROGRAM-ID. A. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 CWD PIC X(100). + 01 LEN_OF_CWD PIC 999 VALUE 100. + PROCEDURE DIVISION. + CALL "getcwd" USING BY REFERENCE CWD BY VALUE LEN_OF_CWD + DISPLAY CWD + goback. + END PROGRAM A. + IDENTIFICATION DIVISION. + PROGRAM-ID. B. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 CWD PIC X(100). + 01 RETURNED-CWD PIC X(100). + 01 LEN_OF_CWD PIC 999 VALUE 100. + PROCEDURE DIVISION. + CALL "getcwd" USING BY REFERENCE CWD BY VALUE LEN_OF_CWD RETURNING RETURNED-CWD + DISPLAY RETURNED-CWD + goback. + END PROGRAM B. + + When we encounter the first call to getcwd, we have no clue as to the + type of the return value, so we assume it is COBOL_FUNCTION_RETURN_TYPE + + When we encounter the second call, we learn that it returns CHAR_P. But + an attempt to change the return type of the function_decl will result + in problems if the function_decl of A is processed by the middle end + before we get a chance to change the getcwd functiona_decl. + + Hence the need for finalized_function_decls, which gets processed + at the end of the file. */ + + finalized_function_decls.push_back(current_function->function_decl); dump_function (TDI_original, current_function->function_decl); if( gg_trans_unit.function_stack.back().context_count ) { - cbl_internal_error("Residual context count!"); + cbl_internal_error("Residual context count"); } gg_trans_unit.function_stack.pop_back(); } void +gg_leaving_the_source_code_file() + { + for( std::vector<tree>::const_iterator it=finalized_function_decls.begin(); + it != finalized_function_decls.end(); + it++ ) + { + //This makes the function visible on the source code module level. + cgraph_node::finalize_function(*it, true); + } + } + +void gg_push_context() { // Sit back, relax, prepare to be amazed. @@ -3084,14 +3047,13 @@ gg_call_expr(tree return_type, const char *function_name, ...) { if(nargs >= ARG_LIMIT) { - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); - yywarn("###### You *must* be joking!"); + yywarn("You *must* be joking"); gcc_unreachable(); } tree arg = va_arg(ap, tree); - if( !arg ) + if( arg == NULL_TREE ) { break; } @@ -3112,7 +3074,7 @@ gg_call_expr(tree return_type, const char *function_name, ...) tree the_func_addr = build1(ADDR_EXPR, build_pointer_type (TREE_TYPE(function_decl)), function_decl); - tree the_call = build_call_array_loc(location_from_lineno(), + tree the_call = build_call_array_loc(gg_token_location(), return_type, the_func_addr, nargs, @@ -3141,14 +3103,13 @@ gg_call(tree return_type, const char *function_name, ...) { if(nargs >= ARG_LIMIT) { - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); - yywarn("###### You *must* be joking!"); + yywarn("You *must* be joking"); gcc_unreachable(); } tree arg = va_arg(ap, tree); - if( !arg ) + if( arg == NULL_TREE ) { break; } @@ -3169,7 +3130,7 @@ gg_call(tree return_type, const char *function_name, ...) tree the_func_addr = build1(ADDR_EXPR, build_pointer_type (TREE_TYPE(function_decl)), function_decl); - tree the_call = build_call_array_loc(location_from_lineno(), + tree the_call = build_call_array_loc(gg_token_location(), return_type, the_func_addr, nargs, @@ -3179,7 +3140,7 @@ gg_call(tree return_type, const char *function_name, ...) } tree -gg_call_expr_list(tree return_type, tree function_name, int param_count, tree args[]) +gg_call_expr_list(tree return_type, tree function_pointer, int param_count, tree args[]) { // Generalized caller. param_count is the count of params in the arg[]] @@ -3194,9 +3155,9 @@ gg_call_expr_list(tree return_type, tree function_name, int param_count, tree ar // Avoid that with something like // gg_assign( dest, gg_call_expr_list(...) ); - tree the_call = build_call_array_loc(location_from_lineno(), + tree the_call = build_call_array_loc(gg_token_location(), return_type, - function_name, + function_pointer, param_count, args); // This routine returns the call_expr; the caller will have to deal with it @@ -3229,7 +3190,7 @@ void gg_exit(tree exit_code) { tree the_call = - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_EXIT), 1, exit_code); @@ -3240,7 +3201,7 @@ void gg_abort() { tree the_call = - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_ABORT), 0); gg_append_statement(the_call); @@ -3251,7 +3212,7 @@ gg_strlen(tree psz) { tree the_call = fold_convert( size_type_node, - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_STRLEN), 1, psz)); @@ -3263,7 +3224,7 @@ gg_strdup(tree psz) { tree the_call = fold_convert( build_pointer_type(char_type_node), - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_STRDUP), 1, psz)); @@ -3277,7 +3238,7 @@ gg_malloc(tree size) { tree the_call = fold_convert( pvoid_type_node, - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_MALLOC), 1, size)); @@ -3289,7 +3250,7 @@ gg_realloc(tree base, tree size) { tree the_call = fold_convert( pvoid_type_node, - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_REALLOC), 2, base, @@ -3313,7 +3274,7 @@ void gg_free(tree pointer) { tree the_call = - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_FREE), 1, pointer); @@ -3414,18 +3375,6 @@ gg_string_literal(const char *string) return build_string_literal(strlen(string)+1, string); } -void -gg_set_current_line_number(int line_number) - { - sv_current_line_number = line_number; - } - -int -gg_get_current_line_number() - { - return sv_current_line_number; - } - tree gg_trans_unit_var_decl(const char *var_name) { @@ -3438,8 +3387,31 @@ gg_trans_unit_var_decl(const char *var_name) return NULL_TREE; } +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wsuggest-attribute=format" + +void +gg_insert_into_assembler(const char ach[]) + { + if( !optimize ) + { + // Create the required generic tag + tree asm_expr = build5_loc( gg_token_location(), + ASM_EXPR, + VOID, + build_string(strlen(ach), ach), + NULL_TREE, + NULL_TREE, + NULL_TREE, + NULL_TREE); + + // And insert it as a statement + gg_append_statement(asm_expr); + } + } + void -gg_insert_into_assembler(const char *format, ...) +gg_insert_into_assemblerf(const char *format, ...) { // Temporarily defeat all ASM_EXPR for optimized code per PR119214 // The correct solution using LABEL_DECL is forthcoming @@ -3458,18 +3430,31 @@ gg_insert_into_assembler(const char *format, ...) vsnprintf(ach, sizeof(ach), format, ap); va_end(ap); - // Create the required generic tag - tree asm_expr = build5_loc( location_from_lineno(), - ASM_EXPR, - VOID, - build_string(strlen(ach), ach), - NULL_TREE, - NULL_TREE, - NULL_TREE, - NULL_TREE); - //SET_EXPR_LOCATION (asm_expr, UNKNOWN_LOCATION); + gg_insert_into_assembler(ach); + } + } +#pragma GCC diagnostic pop - // And insert it as a statement - gg_append_statement(asm_expr); +static location_t sv_token_location_override = 0; + +void +token_location_override(location_t loc) + { + sv_token_location_override = loc; + } + +location_t +gg_token_location() + { + location_t retval; + if( sv_token_location_override ) + { + retval = sv_token_location_override; + sv_token_location_override = 0; } + else + { + retval = current_token_location(); + } + return retval; } diff --git a/gcc/cobol/gengen.h b/gcc/cobol/gengen.h index 8c1bc8d..96e69dd 100644 --- a/gcc/cobol/gengen.h +++ b/gcc/cobol/gengen.h @@ -206,11 +206,6 @@ struct gg_function_t // logical way: All programs are siblings, with the context being the source // code module. The nested aspect is not reflected in the GENERIC tree. - // Truly nested functions are implemented within the generic tree; the - // nested function is completely inside the outer function. This was - // implemented to support paragraphs as callable entities. - bool is_truly_nested; - // This variable, which appears on the stack, contains the exit_address // for the terminating proc of a PERFORM A or PERFORM A THROUGH B tree perform_exit_address; @@ -300,7 +295,7 @@ extern tree gg_trunc(tree integer_type, tree float_var); extern tree gg_cast(tree type, tree var); // Assignment, that is to say, A = B -extern void gg_assign(tree dest, const tree source); +extern tree gg_assign(tree dest, const tree source); // struct creation and field access // Create struct, and access a field in a struct @@ -456,13 +451,16 @@ extern tree gg_strncmp(tree char_star_A, tree char_star_B, tree size_t_N); extern void gg_return(tree operand = NULL_TREE); // These routines are the preample and postamble that bracket everything else -extern void gg_define_function(tree return_type, const char *funcname, ...); -extern tree gg_define_function_with_no_parameters(tree return_type, - const char *funcname, - const char *unmangled_name); +extern tree gg_build_fn_decl(const char *funcname, tree fndecl_type); +extern tree gg_peek_fn_decl(const char *funcname); +extern tree gg_define_function( tree return_type, + const char *funcname, + const char *unmangled_name, + ...); extern void chain_parameter_to_function( tree function_decl, const tree param_type, const char *name); +extern void gg_modify_function_type(tree function_decl, tree return_type); extern void gg_finalize_function(); extern void gg_push_context(); @@ -471,7 +469,9 @@ extern void gg_pop_context(); // These are a generalized call constructor. The first for when you just want // the function called, because you don't care about the return value. The others // are for when you do need the return value. -extern tree gg_call_expr_list(tree return_type, tree function_name, int param_count, tree[]); +extern tree gg_call_expr_list(tree return_type, + tree function_pointer, + int param_count, tree[]); // The following is a garden-variety call, with known return type and known // but in the case where the return value is unimportant. @@ -505,9 +505,6 @@ void gg_goto(tree pointer); void gg_record_statement_list_start(); tree gg_record_statement_list_finish(); -// These routines are in support of PERFORM PARAGRAPH -extern tree gg_get_function_decl(tree return_type, const char *funcname, ...); - // Used to call system exit() extern void gg_exit(tree exit_code); extern void gg_abort(); @@ -528,17 +525,21 @@ extern tree gg_indirect(tree pointer, tree byte_offset = NULL_TREE); extern tree gg_string_literal(const char *string); #define CURRENT_LINE_NUMBER (cobol_location().first_line) -location_t location_from_lineno(); - -// When set to true, use UNKNOWN_LOCATION instead of CURRENT_LINE_NUMBER -extern void gg_set_current_line_number(int line_number); -extern int gg_get_current_line_number(); +extern location_t gg_token_location(); +extern location_t current_token_location(); +extern location_t current_location_minus_one(); +extern void current_location_minus_one_clear(); +extern void token_location_override(location_t loc); extern tree gg_trans_unit_var_decl(const char *var_name); -tree gg_open(tree char_star_A, tree int_B); -tree gg_close(tree int_A); -tree gg_get_indirect_reference(tree pointer, tree offset); -void gg_insert_into_assembler(const char *format, ...); -void gg_modify_function_type(tree function_decl, tree return_type); +extern tree gg_open(tree char_star_A, tree int_B); +extern tree gg_close(tree int_A); +extern tree gg_get_indirect_reference(tree pointer, tree offset); + +extern void gg_insert_into_assembler(const char ach[]); +extern void gg_insert_into_assemblerf(const char *format, ...) ATTRIBUTE_PRINTF_1; + +extern char *gg_show_type(tree type); +extern void gg_leaving_the_source_code_file(); #endif diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc index 721aafb..e7eb971 100644 --- a/gcc/cobol/genmath.cc +++ b/gcc/cobol/genmath.cc @@ -52,7 +52,8 @@ set_up_on_exception_label(cbl_label_t *arithmetic_label) if( !arithmetic_label->structs.arith_error ) { arithmetic_label->structs.arith_error - = (cbl_arith_error_t *)xmalloc(sizeof(struct cbl_arith_error_t) ); + = static_cast<cbl_arith_error_t *> + (xmalloc(sizeof(struct cbl_arith_error_t))); // Set up the address pairs for this clause gg_create_goto_pair(&arithmetic_label->structs.arith_error->over.go_to, &arithmetic_label->structs.arith_error->over.label); @@ -72,8 +73,8 @@ set_up_compute_error_label(cbl_label_t *compute_label) if( !compute_label->structs.compute_error ) { compute_label->structs.compute_error - = (cbl_compute_error_t *) - xmalloc(sizeof(struct cbl_compute_error_t) ); + = static_cast<cbl_compute_error_t *> + (xmalloc(sizeof(struct cbl_compute_error_t))); compute_label->structs.compute_error->compute_error_code = gg_define_int(0); } @@ -95,8 +96,8 @@ arithmetic_operation(size_t nC, cbl_num_result_t *C, size_t nA, cbl_refer_t *A, size_t nB, cbl_refer_t *B, cbl_arith_format_t format, - cbl_label_t *error, - cbl_label_t *not_error, + const cbl_label_t *error, + const cbl_label_t *not_error, tree compute_error, // Pointer to int const char *operation, cbl_refer_t *remainder = NULL) @@ -112,7 +113,6 @@ arithmetic_operation(size_t nC, cbl_num_result_t *C, { TRACE1_HEADER TRACE1_TEXT_ABC("calling ", operation, "") - TRACE1_END for(size_t ii=0; ii<nA; ii++) { TRACE1_INDENT @@ -129,7 +129,6 @@ arithmetic_operation(size_t nC, cbl_num_result_t *C, build_int_cst_type(SIZE_T, ii)); TRACE1_REFER("", B[ii], ""); } - TRACE1_END } // We need to split up cbl_num_result_t into two arrays, one for the refer_t @@ -137,7 +136,7 @@ arithmetic_operation(size_t nC, cbl_num_result_t *C, // Allocate nC+1 in case this is a divide with a REMAINDER - cbl_refer_t *results = (cbl_refer_t *)xmalloc((nC+1) * sizeof( cbl_refer_t )); + std::vector<cbl_refer_t> results(nC + 1); int ncount = 0; if( nC+1 <= MIN_FIELD_BLOCK_SIZE ) @@ -207,7 +206,7 @@ arithmetic_operation(size_t nC, cbl_num_result_t *C, build_array_of_treeplets(1, nA, A); build_array_of_treeplets(2, nB, B); - build_array_of_treeplets(3, ncount, results); + build_array_of_treeplets(3, ncount, results.data()); gg_call(VOID, operation, @@ -223,7 +222,6 @@ arithmetic_operation(size_t nC, cbl_num_result_t *C, { for(size_t ii=0; ii<nC; ii++) { - break; // Breaks on ADD 1 SUB2 GIVING SUB4 both PIC S9(3) COMP TRACE1_INDENT gg_fprintf( trace_handle, 1, "result: C[%ld]: ", @@ -253,9 +251,6 @@ arithmetic_operation(size_t nC, cbl_num_result_t *C, { SHOW_PARSE_END } - - // We need to release all of the refers we allocated: - free(results); } static void @@ -307,7 +302,7 @@ arithmetic_error_handler( cbl_label_t *error, } static bool -is_somebody_float(size_t nA, cbl_refer_t *A) +is_somebody_float(size_t nA, const cbl_refer_t *A) { bool retval = false; for(size_t i=0; i<nA; i++) @@ -322,7 +317,7 @@ is_somebody_float(size_t nA, cbl_refer_t *A) } static bool -is_somebody_float(size_t nC, cbl_num_result_t *C) +is_somebody_float(size_t nC, const cbl_num_result_t *C) { bool retval = false; for(size_t i=0; i<nC; i++) @@ -337,7 +332,7 @@ is_somebody_float(size_t nC, cbl_num_result_t *C) } static bool -all_results_binary(size_t nC, cbl_num_result_t *C) +all_results_binary(size_t nC, const cbl_num_result_t *C) { bool retval = true; @@ -581,10 +576,6 @@ fast_multiply(size_t nC, cbl_num_result_t *C, { // This is a MULTIPLY Format 2 get_binary_value(valB, NULL, B[0].field, refer_offset(B[0])); - } - - if(nB) - { gg_assign(valA, gg_multiply(valA, valB)); } @@ -619,7 +610,7 @@ static bool fast_divide(size_t nC, cbl_num_result_t *C, size_t nA, cbl_refer_t *A, size_t nB, cbl_refer_t *B, - cbl_refer_t remainder) + const cbl_refer_t &remainder) { bool retval = false; if( all_results_binary(nC, C) ) @@ -670,8 +661,10 @@ fast_divide(size_t nC, cbl_num_result_t *C, // We now either divide into C[n] or assign dividend/divisor to C[n]: for(size_t i=0; i<nC; i++ ) { - tree dest_type = tree_type_from_size(C[i].refer.field->data.capacity, 0); - tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, "data"), + tree dest_type = + tree_type_from_size(C[i].refer.field->data.capacity, 0); + tree dest_addr = gg_add(member( C[i].refer.field->var_decl_node, + "data"), refer_offset(C[i].refer)); tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr); if( nB ) @@ -687,16 +680,15 @@ fast_divide(size_t nC, cbl_num_result_t *C, } // This is where we handle any remainder, keeping in mind that for - // nB != 0, the actual dividend is in the value we have named "divisor". - // - // And, yes, I hate comments like that, too. + // nB != 0, the actual dividend is in the value we have named + // "divisor". // We calculate the remainder by calculating // dividend minus quotient * divisor if( remainder.field ) { - tree dest_addr = gg_add(member(remainder.field->var_decl_node, "data"), - refer_offset(remainder)); + dest_addr = gg_add( member(remainder.field->var_decl_node, "data"), + refer_offset(remainder)); dest_type = tree_type_from_size(remainder.field->data.capacity, 0); ptr = gg_cast(build_pointer_type(dest_type), dest_addr); @@ -756,12 +748,6 @@ parser_add( size_t nC, cbl_num_result_t *C, TRACE1_END } - tree compute_error = (tree)compute_error_p; - if( compute_error == NULL ) - { - gg_assign(var_decl_default_compute_error, integer_zero_node); - compute_error = gg_get_address_of(var_decl_default_compute_error); - } bool handled = false; if( fast_add( nC, C, @@ -772,6 +758,13 @@ parser_add( size_t nC, cbl_num_result_t *C, } else { + tree compute_error = (tree)compute_error_p; + if( compute_error == NULL ) + { + gg_assign(var_decl_default_compute_error, integer_zero_node); + compute_error = gg_get_address_of(var_decl_default_compute_error); + } + bool computation_is_float = is_somebody_float(nA, A) || is_somebody_float(nC, C); // We now start deciding which arithmetic routine we are going to use: @@ -992,9 +985,9 @@ parser_add( size_t nC, cbl_num_result_t *C, } void -parser_add( cbl_refer_t cref, - cbl_refer_t aref, - cbl_refer_t bref, +parser_add( const cbl_refer_t& cref, + const cbl_refer_t& aref, + const cbl_refer_t& bref, cbl_round_t rounded) { // This is the simple and innocent C = A + B @@ -1214,9 +1207,9 @@ parser_divide( size_t nC, cbl_num_result_t *C, // C = A / B } void -parser_multiply(cbl_refer_t cref, - cbl_refer_t aref, - cbl_refer_t bref, +parser_multiply(const cbl_refer_t& cref, + const cbl_refer_t& aref, + const cbl_refer_t& bref, cbl_round_t rounded ) { cbl_num_result_t C[1]; @@ -1237,11 +1230,11 @@ parser_multiply(cbl_refer_t cref, } void -parser_divide( cbl_refer_t cref, - cbl_refer_t aref, - cbl_refer_t bref, +parser_divide( const cbl_refer_t& cref, + const cbl_refer_t& aref, + const cbl_refer_t& bref, cbl_round_t rounded, - cbl_refer_t remainder_ref ) + const cbl_refer_t& remainder_ref ) { cbl_num_result_t C[1]; C[0].rounded = rounded; @@ -1389,12 +1382,12 @@ parser_op( struct cbl_refer_t cref, break; } default: - cbl_internal_error( "parser_op() doesn't know how to " - "evaluate \"%s = %s %c %s\"\n", - cref.field->name, - aref.field->name, - op, - bref.field->name); + cbl_internal_error( "%<parser_op()%> doesn%'t know how to " + "evaluate %<%s = %s %c %s%>", + cref.field->name, + aref.field->name, + op, + bref.field->name); break; } } @@ -1452,13 +1445,6 @@ parser_subtract(size_t nC, cbl_num_result_t *C, // C = B - A bool handled = false; - tree compute_error = (tree)compute_error_p; - if( compute_error == NULL ) - { - gg_assign(var_decl_default_compute_error, integer_zero_node); - compute_error = gg_get_address_of(var_decl_default_compute_error); - } - if( fast_subtract(nC, C, nA, A, nB, B, @@ -1468,6 +1454,12 @@ parser_subtract(size_t nC, cbl_num_result_t *C, // C = B - A } else { + tree compute_error = (tree)compute_error_p; + if( compute_error == NULL ) + { + gg_assign(var_decl_default_compute_error, integer_zero_node); + compute_error = gg_get_address_of(var_decl_default_compute_error); + } bool computation_is_float = is_somebody_float(nA, A) || is_somebody_float(nC, C); @@ -1704,9 +1696,9 @@ parser_subtract(size_t nC, cbl_num_result_t *C, // C = B - A } void -parser_subtract(cbl_refer_t cref, // cref = aref - bref - cbl_refer_t aref, - cbl_refer_t bref, +parser_subtract(const cbl_refer_t& cref, // cref = aref - bref + const cbl_refer_t& aref, + const cbl_refer_t& bref, cbl_round_t rounded ) { cbl_num_result_t C[1]; diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc index 3235c38..a5f69a0 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -27,6 +27,9 @@ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ + +// cppcheck-suppress-file duplicateBreak + #include "cobol-system.h" #include "coretypes.h" #include "tree.h" @@ -107,13 +110,13 @@ tree var_decl_nop; // int __gg__nop; tree var_decl_main_called; // int __gg__main_called; #if 0 -#define REFER +#define REFER(a) #else -#define REFER do \ +#define REFER(a) do \ { \ if( getenv("REFER") ) \ { \ - fprintf(stderr, "REFER %s\n", __func__); \ + fprintf(stderr, "REFER %s %s\n", __func__, a); \ } \ }while(0); #endif @@ -232,16 +235,17 @@ tree_type_from_digits(size_t digits, int signable) } void -get_integer_value(tree value, +get_integer_value(tree value, // We know this is a LONG cbl_field_t *field, tree offset, bool check_for_fractional_digits) { - if(field->type == FldLiteralN) + if( field->type == FldLiteralN && field->data.rdigits==0 ) { + gg_assign(value, gg_cast(LONG, field->data_decl_node)); + return; } - Analyze(); // Call this routine when you know the result has to be an integer with no // rdigits. This routine became necessary the first time I saw an @@ -292,15 +296,258 @@ get_any_capacity(cbl_field_t *field) } } -static tree -get_data_offset(cbl_refer_t &refer, - int *pflags = NULL) +/* This routine, used by both get_data_offset and refer_refmod_length, + fetches the refmod_from and refmod_length. If ec-bound-ref-mod checking + is enabled, it does those checks and sets the exception condition when they + are violated. + + The return value for refstart is the actual offset, that is val(7:3) returns + the value 7-1, that is, 6. + */ +static +void +get_and_check_refstart_and_reflen( tree refstart,// LONG returned value + tree reflen, // LONG returned value + const cbl_refer_t &refer) { - REFER; - if( getenv("REFER") ) + const cbl_enabled_exceptions_t& + enabled_exceptions( cdf_enabled_exceptions() ); + + if( !enabled_exceptions.match(ec_bound_ref_mod_e) ) + { + // This is normal operation -- no exception checking. Thus, we won't + // be trying to check for boundaries or integerness. And the programmer + // is accepting the responsibility for bad code: "If you specify + // disaster, disaster is what you get." + + get_integer_value(refstart, + refer.refmod.from->field, + refer_offset(*refer.refmod.from)); + gg_decrement(refstart); + + if( refer.refmod.len ) + { + // The length was specified, so that's what we return: + get_integer_value(reflen, + refer.refmod.len->field, + refer_offset(*refer.refmod.len)); + } + else + { + // The length was not specified, so we need to return the distance + // between refmod.from and the end of the field: + gg_assign(reflen, gg_subtract( get_any_capacity(refer.field), refstart) ); + } + return; + } + + // ec_bound_ref_mode_e checking is enabled: + + get_integer_value(refstart, + refer.refmod.from->field, + refer_offset(*refer.refmod.from), + CHECK_FOR_FRACTIONAL_DIGITS); + + IF( var_decl_rdigits, + ne_op, + integer_zero_node ) + { + // The value for refstart had non-zero decimal places. This is an + // error condition: + set_exception_code(ec_bound_ref_mod_e); + gg_assign(refstart, gg_cast(LONG, integer_one_node)); + gg_assign(var_decl_rdigits, integer_zero_node); + } + ELSE + ENDIF + + // Make refstart zero-based: + gg_decrement(refstart); + + IF( refstart, lt_op, build_int_cst_type(LONG, 0 ) ) { - fprintf(stderr, " %s %s\n", refer.field->name, refer.field->data.initial); + // A negative value for refstart is an error condition: + set_exception_code(ec_bound_ref_mod_e); + gg_assign(refstart, gg_cast(LONG, integer_zero_node)); + // Set reflen to one here, because otherwise it won't be established. + gg_assign(reflen, gg_cast(TREE_TYPE(reflen), integer_one_node)); } + ELSE + { + IF( refstart, gt_op, gg_cast(TREE_TYPE(refstart), get_any_capacity(refer.field)) ) + { + // refstart greater than zero is an error condition: + set_exception_code(ec_bound_ref_mod_e); + gg_assign(refstart, gg_cast(LONG, integer_zero_node)); + // Set reflen to one here, because otherwise it won't be established. + gg_assign(reflen, gg_cast(TREE_TYPE(reflen), integer_one_node)); + } + ELSE + { + if( refer.refmod.len ) + { + get_integer_value(reflen, + refer.refmod.len->field, + refer_offset(*refer.refmod.len), + CHECK_FOR_FRACTIONAL_DIGITS); + IF( var_decl_rdigits, + ne_op, + integer_zero_node ) + { + // length is not an integer, which is an error condition + set_exception_code(ec_bound_ref_mod_e); + gg_assign(reflen, gg_cast(LONG, integer_one_node)); + gg_assign(var_decl_rdigits, integer_zero_node); + } + ELSE + { + // The length is an integer, so we can keep going. + IF( reflen, lt_op, gg_cast(LONG, integer_one_node) ) + { + // length is too small, which is an error condition. + set_exception_code(ec_bound_ref_mod_e); + gg_assign(reflen, gg_cast(LONG, integer_one_node)); + } + ELSE + { + IF( gg_add(refstart, reflen), + gt_op, + gg_cast(TREE_TYPE(refstart), get_any_capacity(refer.field)) ) + { + // Start + Length is too large, which yet again is an error + // condition + set_exception_code(ec_bound_ref_mod_e); + + // Our intentions are honorable. But at this point, where + // we notice that start + length is too long, the + // get_data_offset routine has already been run and + // it's too late to actually change the refstart. There are + // theoretical solutions to this -- mainly, + // get_data_offset needs to check the start + len for + // validity. But I am not going to do it now. Think of this + // as the TODO item. + gg_assign(refstart, gg_cast(LONG, integer_zero_node)); + gg_assign(reflen, gg_cast(LONG, integer_one_node)); + } + ELSE + { + // There are no problems, so there is no error condition, and + // refstart and reflen are correct. + } + ENDIF + } + ENDIF + } + ENDIF + } + else + { + // There is no refmod length, so we default to the remaining characters + gg_assign(reflen, gg_subtract(get_any_capacity(refer.field), + refstart)); + } + } + ENDIF + } + ENDIF + } + +void +get_depending_on_value_from_odo(tree retval, cbl_field_t *odo) + { + /* This routine, called only when we know there is an OCCURS DEPENDING ON + clause, returns the current value of the DEPENDING ON variable. When + ec_bound_odo_e is turned on, and there is any kind of ec-bound-odo + error condition, the value returned is occurs.bounds.lower. + + This should ensure that there is no memory violation in the event of a + declarative with a RESUME NEXT STATEMENT, or before the default_condition + processing can do a controlled exit. + */ + const cbl_enabled_exceptions_t& + enabled_exceptions( cdf_enabled_exceptions() ); + cbl_field_t *depending_on; + depending_on = cbl_field_of(symbol_at(odo->occurs.depending_on)); + + if( !enabled_exceptions.match(ec_bound_odo_e) ) + { + // With no exception testing, just pick up the value. If there is a + // the programmer will simply have to live with the consequences. + get_integer_value(retval, + depending_on, + NULL); + return; + } + + // Bounds checking is enabled, so we test the DEPENDING ON value to be + // between the lower and upper OCCURS limits: + get_integer_value(retval, + depending_on, + NULL, + CHECK_FOR_FRACTIONAL_DIGITS); + + IF( var_decl_rdigits, ne_op, integer_zero_node ) + { + // This needs to evaluate to an integer + set_exception_code(ec_bound_odo_e); + gg_assign(retval, build_int_cst_type( TREE_TYPE(retval), + odo->occurs.bounds.lower)); + gg_assign(var_decl_rdigits, integer_zero_node); + } + ELSE + ENDIF + + IF( retval, gt_op, build_int_cst_type(TREE_TYPE(retval), + odo->occurs.bounds.upper) ) + { + set_exception_code(ec_bound_odo_e); + gg_assign(retval, build_int_cst_type( TREE_TYPE(retval), + odo->occurs.bounds.lower)); + } + ELSE + { + IF( retval, lt_op, build_int_cst_type(TREE_TYPE(retval), + odo->occurs.bounds.lower) ) + { + set_exception_code(ec_bound_odo_e); + gg_assign(retval, build_int_cst_type( TREE_TYPE(retval), + odo->occurs.bounds.lower)); + } + ELSE + ENDIF + IF( retval, lt_op, gg_cast(TREE_TYPE(retval), integer_zero_node) ) + { + set_exception_code(ec_bound_odo_e); + gg_assign(retval, gg_cast(TREE_TYPE(retval), integer_zero_node)); + } + ELSE + ENDIF + } + ENDIF + } + +static +void +get_depending_on_value(tree retval, const cbl_refer_t &refer) + { + /* This routine, called only when we know there is an OCCURS DEPENDING ON + clause, returns the current value of the DEPENDING ON variable. When + ec_bound_odo_e is turned on, and there is any kind of ec-bound-odo + error condition, the value returned is occurs.bounds.lower. + + This should ensure that there is no memory violation in the event of a + declarative with a RESUME NEXT STATEMENT, or before the default_condition + processing can do a controlled exit. + */ + cbl_field_t *odo = symbol_find_odo(refer.field); + get_depending_on_value_from_odo(retval, odo); + } + +static +tree +get_data_offset(const cbl_refer_t &refer, + int *pflags = NULL) + { Analyze(); // This routine returns a tree which is the size_t offset to the data in the // refer/field @@ -314,12 +561,10 @@ get_data_offset(cbl_refer_t &refer, // We have a refer. // At the very least, we have an constant offset int all_flags = 0; - int all_flag_bit = 1; - static tree value64 = gg_define_variable(LONG, ".._gdos_value64", vs_file_static); - - if( refer.nsubscript ) + if( refer.nsubscript() ) { + REFER("subscript"); // We have at least one subscript: // Figure we have three subscripts, so nsubscript is 3 @@ -335,8 +580,9 @@ get_data_offset(cbl_refer_t &refer, // Establish the field_t pointer for walking up through our ancestors: cbl_field_t *parent = refer.field; + int all_flag_bit = 1; // Note the backwards test, because refer->nsubscript is an unsigned value - for(size_t i=refer.nsubscript-1; i<refer.nsubscript; i-- ) + for(size_t i=refer.nsubscript()-1; i<refer.nsubscript(); i-- ) { // We need to search upward for an ancestor with occurs_max: while(parent) @@ -355,29 +601,6 @@ get_data_offset(cbl_refer_t &refer, // Pick up the integer value of the subscript: tree subscript = gg_define_variable(LONG); - get_integer_value(subscript, - refer.subscripts[i].field, - refer_offset(refer.subscripts[i]), - CHECK_FOR_FRACTIONAL_DIGITS); - IF( var_decl_rdigits, - ne_op, - integer_zero_node ) - { - // The subscript isn't an integer - set_exception_code(ec_bound_subscript_e); - gg_assign(var_decl_rdigits, integer_zero_node); - } - ELSE - { - } - ENDIF - - // gg_printf("%s(): We have a subscript of %d from %s\n", - // gg_string_literal(__func__), - // subscript, - // gg_string_literal(refer.subscripts[i].field->name), - // NULL_TREE); - if( (refer.subscripts[i].field->attr & FIGCONST_MASK) == zero_value_e ) { // This refer is a figconst ZERO; we treat it as an ALL ZERO @@ -389,98 +612,105 @@ get_data_offset(cbl_refer_t &refer, // Flag this position as ALL all_flags |= all_flag_bit; } - all_flag_bit <<= 1; - - // Subscript is now a one-based integer - // Make it zero-based: - - gg_decrement(subscript); - // gg_printf("process_this_exception is true\n", NULL_TREE); - IF( subscript, lt_op, gg_cast(TREE_TYPE(subscript), integer_zero_node) ) - { - // The subscript is too small - set_exception_code(ec_bound_subscript_e); - gg_assign(subscript, build_int_cst_type(TREE_TYPE(subscript), 0)); - } - ELSE + else { - // gg_printf("parent->occurs.ntimes() is %d\n", build_int_cst_type(INT, parent->occurs.ntimes()), NULL_TREE); - IF( subscript, - ge_op, - build_int_cst_type(TREE_TYPE(subscript), parent->occurs.ntimes()) ) + const cbl_enabled_exceptions_t& + enabled_exceptions( cdf_enabled_exceptions() ); + if( !enabled_exceptions.match(ec_bound_subscript_e) ) { - // The subscript is too large - set_exception_code(ec_bound_subscript_e); - gg_assign(subscript, build_int_cst_type(TREE_TYPE(subscript), 0)); + // With no exception testing, just pick up the value + get_integer_value(subscript, + refer.subscripts[i].field, + refer_offset(refer.subscripts[i])); } - ELSE + else { - // We have a good subscript: - // Check for an ODO violation: - if( parent->occurs.depending_on ) + get_integer_value(subscript, + refer.subscripts[i].field, + refer_offset(refer.subscripts[i]), + CHECK_FOR_FRACTIONAL_DIGITS); + IF( var_decl_rdigits, + ne_op, + integer_zero_node ) + { + // The subscript isn't an integer + set_exception_code(ec_bound_subscript_e); + gg_assign(subscript, build_int_cst_type(TREE_TYPE(subscript), 1)); + gg_assign(var_decl_rdigits, integer_zero_node); + } + ELSE { - cbl_field_t *depending_on = cbl_field_of(symbol_at(parent->occurs.depending_on)); - get_integer_value(value64, depending_on); - IF( subscript, ge_op, value64 ) + IF( subscript, lt_op, gg_cast(TREE_TYPE(subscript), + integer_one_node) ) { - set_exception_code(ec_bound_odo_e); + // The subscript is too small + set_exception_code(ec_bound_subscript_e); + gg_assign(subscript, build_int_cst_type(TREE_TYPE(subscript), + 1)); } ELSE + { + IF( subscript, + ge_op, + build_int_cst_type( TREE_TYPE(subscript), + parent->occurs.ntimes()) ) + { + // The subscript is too large + set_exception_code(ec_bound_subscript_e); + gg_assign(subscript, build_int_cst_type(TREE_TYPE(subscript), + 1)); + } + ELSE + { + } + ENDIF + } ENDIF } + ENDIF + } + } + + all_flag_bit <<= 1; + + // Although we strictly don't need to look at the ODO value at this + // point, we do want it checked for the purposes of ec-bound-odo + + const cbl_enabled_exceptions_t& + enabled_exceptions( cdf_enabled_exceptions() ); - tree augment = gg_multiply(subscript, get_any_capacity(parent)); - gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment))); + if( enabled_exceptions.match(ec_bound_odo_e) ) + { + if( parent->occurs.depending_on ) + { + static tree value64 = gg_define_variable( LONG, + ".._gdos_value64", + vs_file_static); + cbl_field_t *odo = symbol_find_odo(parent); + get_depending_on_value_from_odo(value64, odo); } - ENDIF } - ENDIF + + // Subscript is now a one-based integer + // Make it zero-based: + + gg_decrement(subscript); + + tree augment = gg_multiply(subscript, get_any_capacity(parent)); + gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment))); + parent = parent_of(parent); } } if( refer.refmod.from ) { + REFER("refmod refstart"); // We have a refmod to deal with static tree refstart = gg_define_variable(LONG, "..gdo_refstart", vs_file_static); + static tree reflen = gg_define_variable(LONG, "..gdo_reflen", vs_file_static); + get_and_check_refstart_and_reflen(refstart, reflen, refer); - get_integer_value(refstart, - refer.refmod.from->field, - refer_offset(*refer.refmod.from), - CHECK_FOR_FRACTIONAL_DIGITS); - IF( var_decl_rdigits, - ne_op, - integer_zero_node ) - { - // refmod offset is not an integer, and has to be - set_exception_code(ec_bound_ref_mod_e); - gg_assign(var_decl_rdigits, integer_zero_node); - } - ELSE - ENDIF - - // Make refstart zero-based: - gg_decrement(refstart); - - IF( refstart, lt_op, gg_cast(LONG, integer_zero_node) ) - { - set_exception_code(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_zero_node)); - } - ELSE - { - tree capacity = get_any_capacity(refer.field); // This is a size_t - IF( refstart, gt_op, gg_cast(LONG, capacity) ) - { - set_exception_code(ec_bound_ref_mod_e); - gg_assign(refstart, build_int_cst_type(TREE_TYPE(refstart), 0)); - } - ELSE - ENDIF - } - ENDIF - - // We have a good refstart gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, refstart))); } @@ -489,14 +719,11 @@ get_data_offset(cbl_refer_t &refer, *pflags = all_flags; } - -// gg_printf("*****>>>>> %s(): returning %p\n", -// gg_string_literal(__func__), -// retval, -// NULL_TREE); return retval; } +static tree tree_type_from_field(const cbl_field_t *field); + void get_binary_value( tree value, tree rdigits, @@ -534,7 +761,7 @@ get_binary_value( tree value, { if( SCALAR_FLOAT_TYPE_P(value) ) { - cbl_internal_error("Can't get float value from %s", field->name); + cbl_internal_error("cannot get %<float%> value from %s", field->name); } else { @@ -1035,18 +1262,13 @@ get_binary_value( tree value, break; } - case FldAlphanumeric: - { - - } - - default: { - fprintf(stderr, "%s(): We know not how to" - " get a binary value from %s\n", - __func__, - cbl_field_type_str(field->type) ); + char *err = xasprintf("%s(): We know not how to" + " get a binary value from %s\n", + __func__, + cbl_field_type_str(field->type) ); + cbl_internal_error("%s", err); abort(); break; } @@ -1064,8 +1286,8 @@ get_binary_value( tree value, } } -tree -tree_type_from_field(cbl_field_t *field) +static tree +tree_type_from_field(const cbl_field_t *field) { gcc_assert(field); return tree_type_from_size(field->data.capacity, field->attr & signable_e); @@ -1358,7 +1580,7 @@ tree_type_from_size(size_t bytes, int signable) static bool -refer_has_depends(cbl_refer_t &refer, refer_type_t refer_type) +refer_has_depends(const cbl_refer_t &refer, refer_type_t refer_type) { if( suppress_dest_depends ) { @@ -1376,7 +1598,7 @@ refer_has_depends(cbl_refer_t &refer, refer_type_t refer_type) // Check if there there is an occurs with a depending_on in the hierarchy bool proceed = false; - cbl_field_t *odo = symbol_find_odo(refer.field); + const cbl_field_t *odo = symbol_find_odo(refer.field); cbl_field_t *depending_on; if( odo && odo != refer.field ) { @@ -1402,7 +1624,7 @@ refer_has_depends(cbl_refer_t &refer, refer_type_t refer_type) { parent1 = p; } - cbl_field_t *parent2 = depending_on; + const cbl_field_t *parent2 = depending_on; while( (p = parent_of(parent2)) ) { parent2 = p; @@ -1464,8 +1686,9 @@ set_exception_code_func(ec_type_t ec, int /*line*/, int from_raise_statement) } bool -process_this_exception(ec_type_t ec) +process_this_exception(const ec_type_t ec) { + const cbl_enabled_exceptions_t& enabled_exceptions( cdf_enabled_exceptions() ); bool retval; if( enabled_exceptions.match(ec) || !skip_exception_processing ) { @@ -1497,7 +1720,7 @@ copy_little_endian_into_place(cbl_field_t *dest, tree value, int rhs_rdigits, bool check_for_error, - tree &size_error) + const tree &size_error) { if( check_for_error ) { @@ -1711,30 +1934,26 @@ char * get_literal_string(cbl_field_t *field) { assert(field->type == FldLiteralA); - char *buffer = NULL; - size_t buffer_length = 0; - if( buffer_length < field->data.capacity+1 ) - { - buffer_length = field->data.capacity+1; - buffer = (char *)xrealloc(buffer, buffer_length); - } + size_t buffer_length = field->data.capacity+1; + char *buffer = static_cast<char *>(xcalloc(1, buffer_length)); + for(size_t i=0; i<field->data.capacity; i++) { buffer[i] = ascii_to_internal(field->data.initial[i]); } - buffer[field->data.capacity] = '\0'; + return buffer; } bool -refer_is_clean(cbl_refer_t &refer) +refer_is_clean(const cbl_refer_t &refer) { if( !refer.field || refer.field->type == FldLiteralN ) { // It is routine for a refer to have no field. It happens when the parser // passes us a refer for an optional parameter that has been omitted, for // example. - + // It is also the case that a FldLiteralN will never have suscripts, or the // like. return true; @@ -1742,202 +1961,50 @@ refer_is_clean(cbl_refer_t &refer) return !refer.all && !refer.addr_of - && !refer.nsubscript + && !refer.nsubscript() && !refer.refmod.from && !refer.refmod.len && !refer_has_depends(refer, refer_source) ; } + /* This routine returns the length portion of a refmod(start:length) reference. It extracts both the start and the length so that it can add them together to make sure that result falls within refer.capacity. + + This routine shouldn't be called unless there is refmod involved. */ static tree // size_t -refer_refmod_length(cbl_refer_t &refer) +refer_refmod_length(const cbl_refer_t &refer) { - REFER; Analyze(); - if( refer.refmod.from || refer.refmod.len ) - { - static tree refstart = gg_define_variable(LONG, "..rrl_refstart", vs_file_static); - static tree reflen = gg_define_variable(LONG, "..rrl_reflen", vs_file_static); - - tree rt_capacity = get_any_capacity(refer.field); // This is a size_t - - get_integer_value(refstart, - refer.refmod.from->field, - refer_offset(*refer.refmod.from), - CHECK_FOR_FRACTIONAL_DIGITS); - IF( var_decl_rdigits, - ne_op, - integer_zero_node ) - { - set_exception_code(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_one_node)); - gg_assign(var_decl_rdigits, integer_zero_node); - } - ELSE - ENDIF - - // Make refstart zero-based: - gg_decrement(refstart); - - IF( refstart, lt_op, build_int_cst_type(LONG, 0 ) ) - { - set_exception_code(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_zero_node)); - // Set reflen to one here, because otherwise it won't be established. - gg_assign(reflen, gg_cast(TREE_TYPE(reflen), integer_one_node)); - } - ELSE - { - IF( refstart, gt_op, gg_cast(TREE_TYPE(refstart), rt_capacity) ) - { - set_exception_code(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_zero_node)); - // Set reflen to one here, because otherwise it won't be established. - gg_assign(reflen, gg_cast(TREE_TYPE(reflen), integer_one_node)); - } - ELSE - { - if( refer.refmod.len ) - { - get_integer_value(reflen, - refer.refmod.len->field, - refer_offset(*refer.refmod.len), - CHECK_FOR_FRACTIONAL_DIGITS); - IF( var_decl_rdigits, - ne_op, - integer_zero_node ) - { - // length is not an integer - set_exception_code(ec_bound_ref_mod_e); - gg_assign(reflen, gg_cast(LONG, integer_one_node)); - gg_assign(var_decl_rdigits, integer_zero_node); - } - ELSE - { - } - ENDIF + REFER("refstart and reflen"); + static tree refstart = gg_define_variable(LONG, "..rrl_refstart", vs_file_static); + static tree reflen = gg_define_variable(LONG, "..rrl_reflen", vs_file_static); - IF( reflen, lt_op, gg_cast(LONG, integer_one_node) ) - { - // length is too small - set_exception_code(ec_bound_ref_mod_e); - gg_assign(reflen, gg_cast(LONG, integer_one_node)); - } - ELSE - { - IF( gg_add(refstart, reflen), - gt_op, - gg_cast(TREE_TYPE(refstart), rt_capacity) ) - { - // Start + Length is too large - set_exception_code(ec_bound_ref_mod_e); + get_and_check_refstart_and_reflen( refstart, reflen, refer); - // Our intentions are honorable. But at this point, where - // we notice that start + length is too long, the - // get_data_offset routine has already been run and - // it's too late to actually change the refstart. There are - // theoretical solutions to this -- mainly, - // get_data_offset needs to check the start + len for - // validity. But I am not going to do it now. Think of this - // as the TODO item. - gg_assign(refstart, gg_cast(LONG, integer_zero_node)); - gg_assign(reflen, gg_cast(LONG, integer_one_node)); - } - ELSE - ENDIF - } - ENDIF - } - else - { - // There is no refmod length, so we default to the remaining characters - tree subtract_expr = gg_subtract( rt_capacity, - refstart); - gg_assign(reflen, subtract_expr); - } - } - ENDIF - } - ENDIF - - // Arrive here with valid values for refstart and reflen: + // Arrive here with a valid value for reflen: - return gg_cast(SIZE_T, reflen); - } - else - { - return size_t_zero_node; - } + return gg_cast(SIZE_T, reflen); } static tree // size_t -refer_fill_depends(cbl_refer_t &refer) +refer_fill_depends(const cbl_refer_t &refer) { - REFER; + REFER(""); // This returns a positive number which is the amount a depends-limited // capacity needs to be reduced. Analyze(); cbl_field_t *odo = symbol_find_odo(refer.field); - cbl_field_t *depending_on; - depending_on = cbl_field_of(symbol_at(odo->occurs.depending_on)); - // refer.field has a relevant DEPENDING ON clause - - // gg_printf("var is %s type is %s\n", - // gg_string_literal(refer.field->name), - // gg_string_literal(cbl_field_type_str(refer.field->type)), - // NULL_TREE); - // gg_printf(" odo is %s\n", gg_string_literal(odo->name), NULL_TREE); - - // gg_printf(" depending_on is %s\n", gg_string_literal(depending_on->name), NULL_TREE); - // fprintf(stderr, - // "symbol_find_odo found %s, with depending_on %s\n", - // odo->name, - // depending_on->name); static tree value64 = gg_define_variable(LONG, "..rfd_value64", vs_file_static); - get_integer_value(value64, - depending_on, - NULL, - CHECK_FOR_FRACTIONAL_DIGITS); - IF( var_decl_rdigits, ne_op, integer_zero_node ) - { - // This needs to evaluate to an integer - set_exception_code(ec_bound_odo_e); - gg_assign(value64, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.upper)); - gg_assign(var_decl_rdigits, integer_zero_node); - } - ELSE - ENDIF - IF( value64, gt_op, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.upper) ) - { - set_exception_code(ec_bound_odo_e); - gg_assign(value64, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.upper)); - } - ELSE - { - IF( value64, lt_op, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.lower) ) - { - set_exception_code(ec_bound_odo_e); - gg_assign(value64, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.lower)); - } - ELSE - ENDIF - IF( value64, lt_op, gg_cast(TREE_TYPE(value64), integer_zero_node) ) - { - set_exception_code(ec_bound_odo_e); - gg_assign(value64, gg_cast(TREE_TYPE(value64), integer_zero_node)); - } - ELSE - ENDIF - } - ENDIF + get_depending_on_value(value64, refer); + // value64 is >= zero and < bounds.upper // We multiply the ODO value by the size of the data capacity to get the @@ -1953,16 +2020,15 @@ refer_fill_depends(cbl_refer_t &refer) } tree // size_t -refer_offset(cbl_refer_t &refer, - int *pflags) +refer_offset(const cbl_refer_t &refer, + int *pflags) { // This routine calculates the effect of a refer offset on the // refer.field->data location. When there are subscripts, the data location - // gets augmented by the (subscript-1)*element_size calculation. And when + // gets augmented by the (subscript-1)*element_size calculation. And when // there is a refmod, the data location additionally gets augmented by // (refmod.from-1) - REFER; if( !refer.field ) { // It's common for the field to be missing. It generally means that an @@ -1981,10 +2047,9 @@ refer_offset(cbl_refer_t &refer, } static -tree -refer_size(cbl_refer_t &refer, refer_type_t refer_type) +tree // size_t +refer_size(const cbl_refer_t &refer, refer_type_t refer_type) { - REFER; Analyze(); static tree retval = gg_define_variable(SIZE_T, "..rs_retval", vs_file_static); @@ -2024,16 +2089,14 @@ refer_size(cbl_refer_t &refer, refer_type_t refer_type) } tree // size_t -refer_size_dest(cbl_refer_t &refer) +refer_size_dest(const cbl_refer_t &refer) { - REFER; return refer_size(refer, refer_dest); } tree // size_t -refer_size_source(cbl_refer_t &refer) +refer_size_source(const cbl_refer_t &refer) { - REFER; /* There are oddities involved with refer_size_source and refer_size_dest. See the comments in refer_has_depends for some explanation. There are other considerations, as well. For example, consider a move, where you @@ -2069,8 +2132,31 @@ refer_size_source(cbl_refer_t &refer) } tree -qualified_data_location(cbl_refer_t &refer) +qualified_data_location(const cbl_refer_t &refer) { return gg_add(member(refer.field->var_decl_node, "data"), refer_offset(refer)); } + +uint64_t +get_time_nanoseconds() +{ + // This code was unabashedly stolen from gcc/timevar.cc. + // It returns the Unix epoch with nine decimal places. + + uint64_t retval = 0; + +#ifdef HAVE_CLOCK_GETTIME + struct timespec ts; + clock_gettime (CLOCK_REALTIME, &ts); + retval = ts.tv_sec * 1000000000 + ts.tv_nsec; + return retval; +#endif +#ifdef HAVE_GETTIMEOFDAY + struct timeval tv; + gettimeofday (&tv, NULL); + retval = tv.tv_sec * 1000000000 + tv.tv_usec * 1000; + return retval; +#endif + return retval; +} diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h index 8244481..f12124e 100644 --- a/gcc/cobol/genutil.h +++ b/gcc/cobol/genutil.h @@ -92,7 +92,7 @@ int get_scaled_rdigits(cbl_field_t *field); int get_scaled_digits(cbl_field_t *field); tree tree_type_from_digits(size_t digits, int signable); tree tree_type_from_size(size_t bytes, int signable); -tree tree_type_from_field(cbl_field_t *field); + void get_binary_value( tree value, tree rdigits, cbl_field_t *field, @@ -118,7 +118,7 @@ void set_exception_code_func(ec_type_t ec, int line, int from_raise_statement=0); #define set_exception_code(ec) set_exception_code_func(ec, __LINE__) -bool process_this_exception(ec_type_t ec); +bool process_this_exception(const ec_type_t ec); #define CHECK_FOR_FRACTIONAL_DIGITS true void get_integer_value(tree value, // This is always a LONG cbl_field_t *field, @@ -130,7 +130,7 @@ void copy_little_endian_into_place(cbl_field_t *dest, tree value, int rhs_rdigits, bool check_for_error, - tree &size_error); + const tree &size_error); tree build_array_of_size_t( size_t N, const size_t *values); void parser_display_internal_field(tree file_descriptor, @@ -138,14 +138,14 @@ void parser_display_internal_field(tree file_descriptor, bool advance=DISPLAY_NO_ADVANCE); char *get_literal_string(cbl_field_t *field); -bool refer_is_clean(cbl_refer_t &refer); +bool refer_is_clean(const cbl_refer_t &refer); -tree refer_offset(cbl_refer_t &refer, +tree refer_offset(const cbl_refer_t &refer, int *pflags=NULL); -tree refer_size_source(cbl_refer_t &refer); -tree refer_size_dest(cbl_refer_t &refer); +tree refer_size_source(const cbl_refer_t &refer); +tree refer_size_dest(const cbl_refer_t &refer); -tree qualified_data_location(cbl_refer_t &refer); +tree qualified_data_location(const cbl_refer_t &refer); void build_array_of_treeplets( int ngroup, size_t N, @@ -154,4 +154,8 @@ void build_array_of_treeplets( int ngroup, void build_array_of_fourplets( int ngroup, size_t N, cbl_refer_t *refers); +void get_depending_on_value_from_odo(tree retval, cbl_field_t *odo); +uint64_t get_time_nanoseconds(); + + #endif diff --git a/gcc/cobol/inspect.h b/gcc/cobol/inspect.h index 9e86a0b..96399f5 100644 --- a/gcc/cobol/inspect.h +++ b/gcc/cobol/inspect.h @@ -53,181 +53,162 @@ static inline bool is_active( const cbl_refer_t& refer ) { return NULL != refer.field; } -template <typename DATA> -struct cbx_inspect_qual_t { +struct cbl_inspect_qual_t { bool initial; - DATA identifier_4; + cbl_refer_t identifier_4; - cbx_inspect_qual_t() : initial(false), identifier_4(DATA()) {} - cbx_inspect_qual_t( bool initial, const DATA& identifier_4 ) + cbl_inspect_qual_t() : initial(false), identifier_4(cbl_refer_t()) {} + cbl_inspect_qual_t( bool initial, const cbl_refer_t& identifier_4 ) : initial(initial), identifier_4(identifier_4) - { - //if( identifier_4.field ) yywarn("%s:qualifying field is '%s'", __func__, identifier_4.field->name); - } - cbx_inspect_qual_t( const cbx_inspect_qual_t& that ) + {} + cbl_inspect_qual_t( const cbl_inspect_qual_t& that ) : initial(that.initial) , identifier_4(that.identifier_4) - { - //if( identifier_4.field ) yywarn("%s:qualifying field is '%s'", __func__, identifier_4.field->name); - } + {} - cbx_inspect_qual_t& operator=( const cbx_inspect_qual_t& that ) { + cbl_inspect_qual_t& operator=( const cbl_inspect_qual_t& that ) { initial = that.initial; identifier_4 = that.identifier_4; - //if( identifier_4.field ) yywarn("%s:qualifying field is '%s'", __func__, identifier_4.field->name); return *this; } bool active() const { return is_active(identifier_4); } - - void clear() { - initial = false; - identifier_4.clear(); - } }; -typedef cbx_inspect_qual_t<cbl_refer_t> cbl_inspect_qual_t; - /* * Data for INSPECT X TALLYING Y FOR. Captures information for operands of * CHARACTERS/ALL/LEADING. The CHARACTERS/ALL/LEADING control is kept at the * next higher level, and may be repeated for each tally. * - * cbx_inspect_match_t::matching is not used with CHARACTERS + * cbl_inspect_match_t::matching is not used with CHARACTERS */ -template <typename DATA> -struct cbx_inspect_match_t { - DATA matching; // identifier-3/5 or literal-1/3 - cbx_inspect_qual_t<DATA> before, after; // phrase 1 - - cbx_inspect_match_t( - const DATA& matching = DATA(), - cbx_inspect_qual_t<DATA> before = cbx_inspect_qual_t<DATA>(), - cbx_inspect_qual_t<DATA> after = cbx_inspect_qual_t<DATA>() - ) - : matching(matching) + +class cbl_inspect_match_t { + friend void dump_inspect_match( const cbl_inspect_match_t& M ); + cbl_refer_t match; // identifier-3/5 or literal-1/3 + cbl_refer_t tally; // collected too soon, belongs to next phrase + public: + cbl_inspect_qual_t before, after; // phrase 1 + + cbl_inspect_match_t() {} + explicit + cbl_inspect_match_t( const cbl_refer_t& matching, + const cbl_inspect_qual_t& before = cbl_inspect_qual_t(), + const cbl_inspect_qual_t& after = cbl_inspect_qual_t() ) + : match(matching) , before(before) , after(after) {} // match all characters bool match_any() const { return !(before.active() || after.active()); } -}; -typedef cbx_inspect_match_t<cbl_refer_t> cbl_inspect_match_t; + void save_premature_tally( const cbl_refer_t& tally ) { + this->tally = tally; // put it here temporarily + } + cbl_refer_t premature_tally() { + if( !tally.field ) { std::swap(match, tally); } + return tally; + } + + const cbl_refer_t& matching( const cbl_refer_t& match ) { + return this->match = match; + } + const cbl_refer_t& matching() const { return match; } + + bool empty() const { + return !is_active(match) && !before.active() && !after.active(); + } +}; /* * Data for INSPECT X REPLACING. The CHARACTERS/ALL/LEADING/FIRST control is * kept at the next higher level, and may be repeated. */ -template <typename DATA> -struct cbx_inspect_replace_t : public cbx_inspect_match_t<DATA> { - DATA replacement; - - cbx_inspect_replace_t( const DATA& matching = DATA(), - const DATA& replacement = DATA() ) - : cbx_inspect_match_t<DATA>(matching) - , replacement(replacement) - {} - cbx_inspect_replace_t( const DATA& matching, - const DATA& replacement, - const cbx_inspect_qual_t<DATA>& before, - const cbx_inspect_qual_t<DATA>& after ) - : cbx_inspect_match_t<DATA>(matching, before, after) +struct cbl_inspect_replace_t : public cbl_inspect_match_t { + cbl_refer_t replacement; + + cbl_inspect_replace_t() {} + cbl_inspect_replace_t( const cbl_refer_t& matching, + const cbl_refer_t& replacement, + const cbl_inspect_qual_t& before, + const cbl_inspect_qual_t& after ) + : cbl_inspect_match_t(matching, before, after) , replacement(replacement) {} }; -typedef cbx_inspect_replace_t<cbl_refer_t> cbl_inspect_replace_t; - // One partial tally or substitution. -template <typename DATA> -struct cbx_inspect_oper_t { +struct cbl_inspect_oper_t { cbl_inspect_bound_t bound; // CHARACTERS/ALL/LEADING/FIRST - size_t n_identifier_3; // N matches/replaces - // either tallies or replaces is NULL - cbx_inspect_match_t<DATA> *matches; - cbx_inspect_replace_t<DATA> *replaces; + // either tallies or replaces is empty + std::vector<cbl_inspect_match_t> matches; + std::vector<cbl_inspect_replace_t> replaces; - cbx_inspect_oper_t( cbl_inspect_bound_t bound, - std::list<cbx_inspect_match_t<DATA>> matches ) + cbl_inspect_oper_t() : bound(bound_characters_e) {} + + explicit cbl_inspect_oper_t( const cbl_inspect_match_t& match, + cbl_inspect_bound_t bound = bound_characters_e ) : bound(bound) - , n_identifier_3( matches.size()) - , matches(NULL) - , replaces(NULL) - { - this->matches = new cbx_inspect_match_t<DATA>[n_identifier_3]; - std::copy( matches.begin(), matches.end(), this->matches ); - } - - cbx_inspect_oper_t( cbl_inspect_bound_t bound, - std::list<cbx_inspect_replace_t<DATA>> replaces ) + { + matches.push_back(match); + } + explicit cbl_inspect_oper_t( const cbl_inspect_replace_t& replace, + cbl_inspect_bound_t bound = bound_characters_e ) : bound(bound) - , n_identifier_3( replaces.size() ) - , matches(NULL) - , replaces(NULL) - { - this->replaces = new cbx_inspect_replace_t<DATA>[n_identifier_3]; - std::copy( replaces.begin(), replaces.end(), this->replaces ); - } - - cbx_inspect_oper_t() - : bound(bound_characters_e) - , n_identifier_3(0) - , matches(NULL) - , replaces(NULL) - { - assert( is_valid() ); - } - - bool is_valid() const { - if( matches && replaces ) return false; - if( matches || replaces ) return n_identifier_3 > 0; - return n_identifier_3 == 0; + { + replaces.push_back(replace); } -}; -typedef cbx_inspect_oper_t<cbl_refer_t> cbl_inspect_oper_t; + cbl_inspect_oper_t( cbl_inspect_bound_t bound, + const std::vector<cbl_inspect_match_t>& matches ) + : bound(bound) + , matches(matches) + {} -// One whole tally or substitution. For REPLACING, nbound == 1 -template <typename DATA> -struct cbx_inspect_t { - DATA tally; // identifier-2: NULL without a tally - size_t nbound; // Each FOR or REPLACING operation starts with a cbl_inspect_bound_t - cbx_inspect_oper_t<DATA> *opers; - - cbx_inspect_t( const DATA& tally = DATA() ) - : tally(tally) - , nbound(0) - , opers(NULL) + cbl_inspect_oper_t( cbl_inspect_bound_t bound, + const std::vector<cbl_inspect_replace_t>& replaces ) + : bound(bound) + , replaces(replaces) {} - cbx_inspect_t( const DATA& tally, cbx_inspect_oper_t<DATA> oper ) - : tally(tally) - , nbound(1) - , opers(NULL) - { - this->opers = new cbx_inspect_oper_t<DATA>[1]; - this->opers[0] = oper; - } - cbx_inspect_t( const DATA& tally, - const std::list<cbx_inspect_oper_t<DATA>>& opers ) - : tally(tally) - , nbound( opers.size() ) - , opers(NULL) - { - this->opers = new cbx_inspect_oper_t<DATA>[nbound]; - std::copy( opers.begin(), opers.end(), this->opers ); - } + + // N matches/replaces + size_t n_identifier_3() const { + return std::max( matches.size(), replaces.size() ); + } + + bool is_valid() const { // only one or the other, never both + bool invalid = !matches.empty() && !replaces.empty(); + return ! invalid; + } }; -typedef cbx_inspect_t<cbl_refer_t> cbl_inspect_t; +// One whole tally or substitution. For REPLACING, nbound == 1 +// FOR and REPLACING start with a cbl_inspect_bound_t +struct cbl_inspect_t : public std::vector<cbl_inspect_oper_t> { + cbl_refer_t tally; // field is NULL for REPLACING + cbl_inspect_t() {} + cbl_inspect_t( size_t n, const cbl_inspect_oper_t& oper ) + : std::vector<cbl_inspect_oper_t>(n, oper) + {} + cbl_inspect_t( const cbl_refer_t& tally, + const std::vector<cbl_inspect_oper_t>& opers ) + : std::vector<cbl_inspect_oper_t>(opers) + , tally(tally) + {} + + size_t nbound() const { return size(); } +}; +typedef std::vector<cbl_inspect_t> cbl_inspect_opers_t; /* * Runtime */ -void parser_inspect( cbl_refer_t input, bool backward, - size_t ninspect, cbl_inspect_t *inspects ); +void parser_inspect( const cbl_refer_t& input, + bool backward, + cbl_inspect_opers_t& inspects ); + void parser_inspect_conv( cbl_refer_t input, bool backward, cbl_refer_t original, cbl_refer_t replacement, diff --git a/gcc/cobol/lang-specs.h b/gcc/cobol/lang-specs.h index 78e84c0..b7f1517 100644 --- a/gcc/cobol/lang-specs.h +++ b/gcc/cobol/lang-specs.h @@ -34,7 +34,7 @@ {".CBL", "@cobol", 0, 0, 0}, {"@cobol", "cobol1 %i %(cc1_options) " - "%{D*} %{E} %{I*} %{fmax-errors*} %{fsyntax-only*} " + "%{D*} %{E} %{I*} %{M} %{fmax-errors*} %{fsyntax-only*} " "%{fcobol-exceptions*} " "%{copyext} " "%{fstatic-call} %{fdefaultbyte} " diff --git a/gcc/cobol/lang.opt b/gcc/cobol/lang.opt index 59278a1..1f2a616 100644 --- a/gcc/cobol/lang.opt +++ b/gcc/cobol/lang.opt @@ -38,6 +38,11 @@ Cobol Joined Separate ;; -I <dir> Add copybook search directory ; Documented in c.opt +M +Cobol +; Documented in c.opt + + dialect Cobol Joined Separate Enum(dialect_type) EnumBitSet Var(cobol_dialect) Accept COBOL constructs used by non-ISO compilers diff --git a/gcc/cobol/lang.opt.urls b/gcc/cobol/lang.opt.urls index 69f5297..78fc491 100644 --- a/gcc/cobol/lang.opt.urls +++ b/gcc/cobol/lang.opt.urls @@ -10,6 +10,9 @@ UrlSuffix(gcc/Preprocessor-Options.html#index-D-1) I UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) +M +UrlSuffix(gcc/Preprocessor-Options.html#index-M) LangUrlSuffix_D(gdc/Code-Generation.html#index-M) + ffixed-form LangUrlSuffix_Fortran(gfortran/Fortran-Dialect-Options.html#index-ffixed-form) diff --git a/gcc/cobol/lexio.cc b/gcc/cobol/lexio.cc index 2db1af2..52d1aff 100644 --- a/gcc/cobol/lexio.cc +++ b/gcc/cobol/lexio.cc @@ -38,29 +38,24 @@ extern int yy_flex_debug; -static struct { - bool first_file, explicitly; - int column, right_margin; - bool inference_pending() { - bool tf = first_file && !explicitly; - first_file = false; - return tf; - } - inline bool is_fixed() const { return column == 7; } - inline bool is_reffmt() const { return is_fixed() && right_margin == 73; } - inline bool is_free() const { return ! is_fixed(); } - - const char * description() const { - if( is_reffmt() ) return "REFERENCE"; - if( is_fixed() ) return "FIXED"; - if( is_free() ) return "FREE"; - gcc_unreachable(); - } -} indicator = { true, false, 0, 0 }; +source_format_t& cdf_source_format(); + +void +source_format_t::infer( const char *bol, bool want_reference_format ) { + if( bol ) { + left = 7; + if( want_reference_format ) { + right = 73; + } + } + dbgmsg("%s:%d: %s format detected", __func__, __LINE__, + description()); +} + // public source format test functions -bool is_fixed_format() { return indicator.is_fixed(); } -bool is_reference_format() { return indicator.is_reffmt(); } +bool is_fixed_format() { return cdf_source_format().is_fixed(); } +bool is_reference_format() { return cdf_source_format().is_reffmt(); } static bool debug_mode = false; @@ -76,11 +71,10 @@ static bool debug_mode = false; */ static inline int left_margin() { - return indicator.column == 0? indicator.column : indicator.column - 1; + return cdf_source_format().left_margin(); } static inline int right_margin() { - return indicator.right_margin == 0? - indicator.right_margin : indicator.right_margin - 1; + return cdf_source_format().right_margin(); } /* @@ -89,18 +83,9 @@ static inline int right_margin() { * When setting back to 0 (free), the right margin is also reset to 0. */ void -cobol_set_indicator_column( int column ) -{ - indicator.explicitly = true; - if( column == 0 ) indicator.right_margin = 0; - if( column < 0 ) { - column = -column; - indicator.right_margin = 73; - } - indicator.column = column; -} +cobol_set_indicator_column( int column ); -bool include_debug() { return indicator.column == 7 && debug_mode; } +bool include_debug() { return is_fixed_format() && debug_mode; } bool set_debug( bool tf ) { return debug_mode = tf && is_fixed_format(); } static bool nonblank( const char ch ) { return !isblank(ch); } @@ -114,7 +99,7 @@ start_of_line( char *bol, char *eol ) { static inline char * continues_at( char *bol, char *eol ) { - if( indicator.column == 0 ) return NULL; // cannot continue in free format + if( cdf_source_format().is_free() ) return NULL; // cannot continue in free format bol += left_margin(); if( *bol != '-' ) return NULL; // not a continuation line return start_of_line(++bol, eol); @@ -123,8 +108,8 @@ continues_at( char *bol, char *eol ) { // Return pointer to indicator column. Test ch if provided. // NULL means no indicator column or tested value not present. static inline char * -indicated( char *bol, char *eol, char ch = '\0' ) { - if( indicator.column == 0 && *bol != '*' ) { +indicated( char *bol, const char *eol, char ch = '\0' ) { + if( cdf_source_format().left_margin() == 0 && *bol != '*' ) { return NULL; // no indicator column in free format, except for comments } gcc_assert(bol != NULL); @@ -140,10 +125,10 @@ indicated( char *bol, char *eol, char ch = '\0' ) { static char * remove_inline_comment( char *bol, char *eol ) { - static char ends = '\0'; char *nl = std::find(bol, eol, '\n'); if( bol < nl ) { + static char ends = '\0'; std::swap(*nl, ends); char *comment = strstr(bol, "*>"); if( comment ) { @@ -208,10 +193,10 @@ maybe_add_space(const span_t& pattern, replace_t& recognized) { } if( befter[0] == blank || befter[1] == blank ) { - char *s = xasprintf( "%s%.*s%s", - befter[0], - recognized.after.size(), recognized.after.p, - befter[1] ); + const char *s = xasprintf( "%s%.*s%s", + befter[0], + recognized.after.size(), recognized.after.p, + befter[1] ); recognized.after = span_t(s, s + strlen(s)); } } @@ -266,7 +251,9 @@ recognize_replacements( filespan_t mfile, std::list<replace_t>& pending_replacem span_t found(mfile.eodata, mfile.eodata); - if( regex_search( mfile.ccur(), (const char *)mfile.eodata, cm, re) ) { + if( regex_search( mfile.ccur(), + const_cast<const char *>(mfile.eodata), + cm, re) ) { gcc_assert(cm[1].matched); found = span_t( cm[1].first, cm[1].second ); if( yy_flex_debug ) { @@ -301,7 +288,8 @@ recognize_replacements( filespan_t mfile, std::list<replace_t>& pending_replacem bol = next.found.pend; if( yy_flex_debug ) { - size_t n = std::count((const char *)mfile.data, recognized.before.p, '\n'); + size_t n = std::count(const_cast<const char *>(mfile.data), + recognized.before.p, '\n'); dbgmsg( "%s:%d: line " HOST_SIZE_T_PRINT_UNSIGNED " @ " HOST_SIZE_T_PRINT_UNSIGNED ": '%s'\n/%.*s/%.*s/", __func__, __LINE__, @@ -317,10 +305,11 @@ recognize_replacements( filespan_t mfile, std::list<replace_t>& pending_replacem next.found = span_t(mfile.eodata, mfile.eodata); regex re(next.directive.before.p, extended_icase); - if( regex_search(bol, (const char *)mfile.eodata, cm, re) ) { + if( regex_search(bol, const_cast<const char *>(mfile.eodata), cm, re) ) { gcc_assert(cm[1].matched); next.found = span_t( cm[1].first, cm[1].second ); - size_t n = std::count((const char *)mfile.data, next.found.p, '\n'); + size_t n = std::count(const_cast<const char *>(mfile.data), + next.found.p, '\n'); if( false ) dbgmsg("%s:%d next '%.*s' will be on line " HOST_SIZE_T_PRINT_UNSIGNED " (offset " HOST_SIZE_T_PRINT_UNSIGNED ")", __func__, __LINE__, @@ -332,7 +321,69 @@ recognize_replacements( filespan_t mfile, std::list<replace_t>& pending_replacem } static void +check_push_pop_directive( filespan_t& mfile ) { + char eol = '\0'; + const char *p = std::find(mfile.cur, mfile.eol, '>'); + if( ! (p < mfile.eol && p[1] == *p ) ) return; + + const char pattern[] = + ">>[[:blank:]]*(push|pop)[[:blank:]]+" + "(" + "all|" + "call-convention|" + "cobol-words|" + "define|" + "source[[:blank:]]+format|" + "turn" + ")"; + static regex re(pattern, extended_icase); + + // show contents of marked subexpressions within each match + cmatch cm; + + std::swap(*mfile.eol, eol); // see implementation for excuses + bool ok = regex_search(p, const_cast<const char *>(mfile.eol), cm, re); + std::swap(*mfile.eol, eol); + + if( ok ) { + gcc_assert(cm.size() > 1); + bool push = TOUPPER(cm[1].first[1]) == 'U'; + switch( TOUPPER(cm[2].first[0]) ) { + case 'A': // ALL + push? cdf_push() : cdf_pop(); + break; + case 'C': + switch( TOUPPER(cm[2].first[1]) ) { + case 'A': // CALL-CONVENTION + push? cdf_push_call_convention() : cdf_pop_call_convention(); + break; + case 'O': // COBOL-WORDS + push? cdf_push_current_tokens() : cdf_pop_current_tokens(); + break; + default: + gcc_unreachable(); + } + break; + case 'D': // DEFINE + push? cdf_push_dictionary() : cdf_pop_dictionary(); + break; + case 'S': // SOURCE FORMAT + push? cdf_push_source_format() : cdf_pop_source_format(); + break; + case 'T': // TURN + push? cdf_push_enabled_exceptions() : cdf_pop_enabled_exceptions(); + break; + default: + gcc_unreachable(); + } + erase_line(const_cast<char*>(cm[0].first), + const_cast<char*>(cm[0].second)); + } +} + +static void check_source_format_directive( filespan_t& mfile ) { + char eol = '\0'; const char *p = std::find(mfile.cur, mfile.eol, '>'); if( ! (p < mfile.eol && p[1] == *p ) ) return; @@ -345,7 +396,12 @@ check_source_format_directive( filespan_t& mfile ) { // show contents of marked subexpressions within each match cmatch cm; - if( regex_search(p, (const char *)mfile.eol, cm, re) ) { + + std::swap(*mfile.eol, eol); // see implementation for excuses + bool ok = regex_search(p, const_cast<const char *>(mfile.eol), cm, re); + std::swap(*mfile.eol, eol); + + if( ok ) { gcc_assert(cm.size() > 1); switch( cm[3].length() ) { case 4: @@ -361,11 +417,11 @@ check_source_format_directive( filespan_t& mfile ) { dbgmsg( "%s:%d: %s format set, on line " HOST_SIZE_T_PRINT_UNSIGNED, __func__, __LINE__, - indicator.column == 7? "FIXED" : "FREE", + cdf_source_format().description(), (fmt_size_t)mfile.lineno() ); - char *bol = indicator.is_fixed()? mfile.cur : const_cast<char*>(cm[0].first); + char *bol = cdf_source_format().is_fixed()? mfile.cur : const_cast<char*>(cm[0].first); + gcc_assert(cm[0].second <= mfile.eol); erase_line(bol, const_cast<char*>(cm[0].second)); - mfile.cur = const_cast<char*>(cm[0].second); } } @@ -459,9 +515,9 @@ struct replacing_term_t { bool matched, done; span_t leading_trailing, term, stmt; - replacing_term_t(const char input[]) : matched(false), done(false) { - stmt = span_t(input, input); - } + explicit replacing_term_t(const char input[]) + : matched(false), done(false), stmt(span_t(input, input)) + {} }; extern YYLTYPE yylloc; @@ -531,7 +587,7 @@ update_yylloc( const csub_match& stmt, const csub_match& term ) { static replacing_term_t parse_replacing_term( const char *stmt, const char *estmt ) { - gcc_assert(stmt); gcc_assert(estmt); gcc_assert(stmt < estmt); + gcc_assert(stmt); gcc_assert(estmt); gcc_assert(stmt <= estmt); replacing_term_t output(stmt); static const char pattern[] = @@ -741,7 +797,7 @@ parse_replacing_pair( const char *stmt, const char *estmt ) { } } if( pair.stmt.p ) { - yywarn("CDF syntax error '%*s'", (int)pair.stmt.size(), pair.stmt.p); + yywarn("CDF syntax error '%.*s'", (int)pair.stmt.size(), pair.stmt.p); } else { // This eliminated a compiler warning about "format-overflow" @@ -809,7 +865,7 @@ parse_replace_pairs( const char *stmt, const char *estmt, bool is_copy_stmt ) { } span_t& before(parsed.replace.before); - span_t& after(parsed.replace.after); + const span_t& after(parsed.replace.after); const char *befter[2] = { nonword_ch, nonword_ch }; gcc_assert(before.p < before.pend); @@ -877,7 +933,7 @@ struct copy_descr_t { }; static YYLTYPE -location_in( const filespan_t& mfile, const csub_match cm ) { +location_in( const filespan_t& mfile, const csub_match& cm ) { YYLTYPE loc { int(mfile.lineno() + 1), int(mfile.colno() + 1), int(mfile.lineno() + 1), int(mfile.colno() + 1) @@ -885,7 +941,7 @@ location_in( const filespan_t& mfile, const csub_match cm ) { gcc_assert(mfile.cur <= cm.first && cm.second <= mfile.eodata); auto nline = std::count(cm.first, cm.second, '\n'); if( nline ) { - gcc_assert(loc.first_line < nline); + gcc_assert(nline < loc.first_line); loc.first_line -= nline; auto p = static_cast<const char*>(memrchr(cm.first, '\n', cm.length())); loc.last_column = (cm.second) - p; @@ -928,7 +984,7 @@ parse_copy_directive( filespan_t& mfile ) { copy_stmt.p = mfile.eodata; if( regex_search(mfile.ccur(), - (const char *)mfile.eodata, cm, re) ) { + const_cast<const char *>(mfile.eodata), cm, re) ) { copy_stmt = span_t( cm[0].first, cm[0].second ); if( yy_flex_debug ) { size_t nnl = 1 + count_newlines(mfile.data, copy_stmt.p); @@ -981,7 +1037,7 @@ parse_copy_directive( filespan_t& mfile ) { std::pair<std::list<replace_t>, char*> result = parse_replace_pairs( cm[0].second, mfile.eodata, true ); - std::list<replace_t>& replacements(result.first); + const std::list<replace_t>& replacements(result.first); outcome.parsed = (outcome.nreplace = replacements.size()) > 0; if( outcome.parsed ) { replace_directives.push(replacements); @@ -1008,7 +1064,7 @@ parse_copy_directive( filespan_t& mfile ) { } static char * -parse_replace_last_off( filespan_t& mfile ) { +parse_replace_last_off( const filespan_t& mfile ) { static const char pattern[] = "REPLACE" "[[:space:]]+" "(LAST[[:space:]]+)?OFF[[:space:]]*[.]" @@ -1018,7 +1074,7 @@ parse_replace_last_off( filespan_t& mfile ) { // REPLACE [LAST] OFF? bool found = regex_search(mfile.ccur(), - (const char *)mfile.eodata, cm, re); + const_cast<const char *>(mfile.eodata), cm, re); gcc_assert(found); // caller ensures gcc_assert(cm.size() == 2); @@ -1073,7 +1129,7 @@ parse_replace_text( filespan_t& mfile ) { (fmt_size_t)current_lineno, len, mfile.cur); } - if( ! regex_search(mfile.ccur(), (const char *)mfile.eodata, cm, re) ) { + if( ! regex_search(mfile.ccur(), mfile.eodata, cm, re) ) { dbgmsg( "%s:%d: line " HOST_SIZE_T_PRINT_UNSIGNED ": not a REPLACE statement:\n'%.*s'", __func__, __LINE__, (fmt_size_t)current_lineno, @@ -1109,7 +1165,7 @@ parse_replace_text( filespan_t& mfile ) { std::pair<std::list<replace_t>, char*> result = parse_replace_pairs(replace_stmt.p, replace_stmt.pend, false); - std::list<replace_t>& replacements(result.first); + const std::list<replace_t>& replacements(result.first); replace_directives.push( replacements ); if( yy_flex_debug ) { @@ -1147,7 +1203,7 @@ parse_replace_directive( filespan_t& mfile ) { next_directive = mfile.eodata; if( regex_search(mfile.ccur(), - (const char *)mfile.eodata, cm, re) ) { + const_cast<const char *>(mfile.eodata), cm, re) ) { gcc_assert(cm[1].matched); next_directive = cm[0].first; @@ -1323,13 +1379,13 @@ lexer_input( char buf[], int max_size, FILE *input ) { for( auto p = mfile.cur; p < next; *output.pos++ = *p++ ) { static bool at_bol = false; if( at_bol ) { - auto nonblank = std::find_if( p, next, + auto nonblank_l = std::find_if( p, next, []( char ch ) { return !isblank(ch); } ); - if( nonblank + 1 < next ) { - if( *nonblank == '\r' ) nonblank++; // Windows - if( *nonblank == '\n' ) { - p = nonblank; + if( nonblank_l + 1 < next ) { + if( *nonblank_l == '\r' ) nonblank_l++; // Windows + if( *nonblank_l == '\n' ) { + p = nonblank_l; continue; } } @@ -1409,7 +1465,7 @@ preprocess_filter_add( const char input[] ) { auto filename = find_filter(filter.c_str()); if( !filename ) { - yywarn("preprocessor '%s/%s' not found", getcwd(NULL, 0), filter); + yywarn("preprocessor '%s/%s' not found", getcwd(NULL, 0), filter.c_str()); return false; } preprocessor_filters.push_back( std::make_pair(xstrdup(filename), options) ); @@ -1455,9 +1511,8 @@ cdftext::lex_open( const char filename[] ) { int output = open_output(); - // Process any files supplied by the -include comamnd-line option. + // Process any files supplied by the -include command-line option. for( auto name : included_files ) { - int input; if( -1 == (input = open(name, O_RDONLY)) ) { yyerrorvl(1, "", "cannot open -include file %s", name); continue; @@ -1466,7 +1521,10 @@ cdftext::lex_open( const char filename[] ) { filespan_t mfile( free_form_reference_format( input ) ); process_file( mfile, output ); + + cobol_filename_restore(); // process_file restores only for COPY } + included_files.clear(); cobol_filename(filename, inode_of(input)); filespan_t mfile( free_form_reference_format( input ) ); @@ -1488,7 +1546,7 @@ cdftext::lex_open( const char filename[] ) { argv[0] = filter; auto last_argv = std::transform( options.begin(), options.end(), argv.begin() + 1, - []( std::string& opt ) { + []( const std::string& opt ) { return xstrdup(opt.c_str()); } ); *last_argv = NULL; @@ -1517,11 +1575,11 @@ cdftext::lex_open( const char filename[] ) { int status; auto kid = wait(&status); gcc_assert(pid == kid); - if( kid == -1 ) cbl_err( "failed waiting for pid %d", pid); + if( kid == -1 ) cbl_err( "failed waiting for pid %ld", static_cast<long>(pid)); if( WIFSIGNALED(status) ) { - cbl_errx( "%s pid %d terminated by %s", - filter, kid, strsignal(WTERMSIG(status)) ); + cbl_errx( "%s pid %ld terminated by %s", + filter, static_cast<long>(kid), strsignal(WTERMSIG(status)) ); } if( WIFEXITED(status) ) { if( (status = WEXITSTATUS(status)) != 0 ) { @@ -1539,7 +1597,7 @@ int cdftext::open_input( const char filename[] ) { int fd = open(filename, O_RDONLY); if( fd == -1 ) { - dbgmsg( "could not open '%s': %m", filename ); + dbgmsg( "could not open '%s': %s", filename, xstrerror(errno) ); } verbose_file_reader = NULL != getenv("GCOBOL_TEMPDIR"); @@ -1553,9 +1611,9 @@ cdftext::open_input( const char filename[] ) { int cdftext::open_output() { char *name = getenv("GCOBOL_TEMPDIR"); - int fd; if( name && 0 != strcmp(name, "/") ) { + int fd; char * stem = xasprintf("%sXXXXXX", name); if( -1 == (fd = mkstemp(stem)) ) { cbl_err( "could not open temporary file '%s' (%s)", @@ -1627,7 +1685,7 @@ bool lexio_dialect_mf(); */ static const char * valid_sequence_area( const char *data, const char *eodata ) { - + for( const char *p = data; (p = std::find_if(p, eodata, is_p)) != eodata; p++ ) @@ -1650,7 +1708,7 @@ valid_sequence_area( const char *data, const char *eodata ) { } } } - return nullptr; + return nullptr; } /* @@ -1682,26 +1740,21 @@ cdftext::free_form_reference_format( int input ) { size_t lineno; bytespan_t line; // construct with length zero - current_line_t( char data[] ) : lineno(0), line(data, data) {} + explicit current_line_t( char data[] ) : lineno(0), line(data, data) {} } current( mfile.data ); /* - * Infer source code format. + * Infer source code format. */ - if( indicator.inference_pending() ) { + if( cdf_source_format().inference_pending() ) { const char *bol = valid_sequence_area(mfile.data, mfile.eodata); if( bol ) { - indicator.column = 7; - if( infer_reference_format(bol, mfile.eodata) ) { - indicator.right_margin = 73; - } + cdf_source_format().infer( bol, infer_reference_format(bol, mfile.eodata) ); } - - dbgmsg("%s:%d: %s format detected", __func__, __LINE__, - indicator.description()); } while( mfile.next_line() ) { + check_push_pop_directive(mfile); check_source_format_directive(mfile); remove_inline_comment(mfile.cur, mfile.eol); @@ -1822,15 +1875,15 @@ cdftext::free_form_reference_format( int input ) { void cdftext::process_file( filespan_t mfile, int output, bool second_pass ) { static size_t nfiles = 0; - std::list<replace_t> replacements; - __gnu_cxx::stdio_filebuf<char> outbuf(fdopen(output, "w"), std::ios::out); + __gnu_cxx::stdio_filebuf<char> outbuf(fdopen(output, "a"), std::ios::out); std::ostream out(&outbuf); std::ostream_iterator<char> ofs(out); // indicate current file static const char file_push[] = "\f#FILE PUSH ", file_pop[] = "\f#FILE POP\f"; + if( !included_files.empty() ) { ++nfiles; }; // force push/pop of included filename if( !second_pass && nfiles++ ) { static const char delimiter[] = "\f"; const char *filename = cobol_filename(); @@ -1850,7 +1903,7 @@ cdftext::process_file( filespan_t mfile, int output, bool second_pass ) { []( char ch ) { return ch == '\n'; } ); struct { int in, out; filespan_t mfile; } copy; dbgmsg("%s:%d: line " HOST_SIZE_T_PRINT_UNSIGNED ", opening %s on fd %d", - __func__, __LINE__,mfile.lineno(), + __func__, __LINE__, (fmt_size_t)mfile.lineno(), copybook.source(), copybook.current()->fd); copy.in = copybook.current()->fd; copy.mfile = free_form_reference_format( copy.in ); @@ -1886,31 +1939,12 @@ cdftext::process_file( filespan_t mfile, int output, bool second_pass ) { continue; // No active REPLACE directive. } - std::list<span_t> segments = segment_line(mfile); // no replace yields - // // 1 segment + std::list<span_t> segments = segment_line(mfile); for( const auto& segment : segments ) { std::copy(segment.p, segment.pend, ofs); } - if( segments.size() == 2 ) { - struct { - size_t before, after; - int delta() const { return before - after; } } nlines; - nlines.before = std::count(segments.front().p, - segments.front().pend, '\n'); - nlines.after = std::count(segments.back().p, segments.back().pend, '\n'); - if( nlines.delta() < 0 ) { - yywarn("line %zu: REPLACED %zu lines with %zu lines, " - "line count off by %d", mfile.lineno(), - nlines.before, nlines.after, nlines.delta()); - } - int nnl = nlines.delta(); - while( nnl-- > 0 ) { - static const char nl[] = "\n"; - std::copy(nl, nl + 1, ofs); - } - } out.flush(); } // end of file @@ -1918,6 +1952,7 @@ cdftext::process_file( filespan_t mfile, int output, bool second_pass ) { std::copy(file_pop, file_pop + strlen(file_pop), ofs); out.flush(); } + if( !included_files.empty() ) { --nfiles; }; } std::list<span_t> @@ -1933,12 +1968,30 @@ cdftext::segment_line( filespan_t& mfile ) { return output; } + /* + * If the replacement changes the number of lines in the replaced text, we + * need to reset the line number, because the next statement is on a + * different line in the manipulated text than in the original. Before each + * replacement, set the original line number. After each replacement, set + * the line number after the elided text on the next line. + */ for( const replace_t& segment : pending ) { gcc_assert(mfile.cur <= segment.before.p); gcc_assert(segment.before.pend <= mfile.eodata); + struct { unsigned long ante, post; } lineno = { + gb4(mfile.lineno()), gb4(mfile.lineno() + segment.after.nlines()) + }; + const char *directive = lineno.ante == lineno.post? + nullptr : xasprintf("\n#line %lu \"%s\"\n", + lineno.ante, cobol_filename()); + + if( directive ) + output.push_back( span_t(strlen(directive), directive) ); output.push_back( span_t(mfile.cur, segment.before.p) ); output.push_back( span_t(segment.after.p, segment.after.pend ) ); + if( directive ) + output.push_back( span_t(strlen(directive), directive) ); mfile.cur = const_cast<char*>(segment.before.pend); } @@ -1954,5 +2007,3 @@ cdftext::segment_line( filespan_t& mfile ) { return output; } - -//////// End of the cdf_text.h file diff --git a/gcc/cobol/lexio.h b/gcc/cobol/lexio.h index cf7f53a..ba4ef0a 100644 --- a/gcc/cobol/lexio.h +++ b/gcc/cobol/lexio.h @@ -43,7 +43,6 @@ #define SPACE ' ' bool lexer_echo(); - bool is_reference_format(); static inline bool isquote( char ch ) { @@ -70,7 +69,9 @@ erase_source( char *src, char *esrc ) { struct bytespan_t { char *data, *eodata; - bytespan_t( char *data = NULL, char *eodata = NULL ) + bytespan_t() : data( nullptr), eodata(nullptr) {} + + bytespan_t( char *data, char *eodata ) : data(data), eodata(eodata) { if( eodata < data ) { @@ -111,19 +112,7 @@ struct bytespan_t { } }; -/* Location type. Borrowed from parse.h as generated by Bison. */ -#if ! defined YYLTYPE && ! defined YYLTYPE_IS_DECLARED -typedef struct YYLTYPE YYLTYPE; -struct YYLTYPE -{ - int first_line; - int first_column; - int last_line; - int last_column; -}; -# define YYLTYPE_IS_DECLARED 1 -# define YYLTYPE_IS_TRIVIAL 1 -#endif +// YYLTYPE supplied by cbldiag.h. Borrowed from parse.h as generated by Bison. struct filespan_t : public bytespan_t { char *cur, *eol, *quote; @@ -137,7 +126,7 @@ struct filespan_t : public bytespan_t { {} filespan_t(void *p, size_t len) : bytespan_t( static_cast<char*>(p), static_cast<char*>(p) + len ) - , cur(data), eol(data), quote(NULL), iline(0), line_quote72(0) + , cur(data), eol(data), quote(NULL), iline(0), icol(0), line_quote72(0) {} size_t lineno() const { return iline; } @@ -237,6 +226,7 @@ struct span_t { span_t( const char *data, const char *eodata ) : p(data), pend(eodata) { verify(); } + // cppcheck-suppress operatorEqRetRefThis span_t& operator=( const csub_match& cm ) { p = cm.first; pend = cm.second; @@ -245,6 +235,8 @@ struct span_t { int size() const { return pend - p; } + size_t nlines() const { return p && pend? std::count(p, pend, '\n') : 0; } + span_t dup() const { auto output = new char[size() + 1]; auto eout = std::copy(p, pend, output); @@ -252,15 +244,22 @@ struct span_t { return span_t(output, eout); } const char * has_nul() const { - auto p = std::find(this->p, pend, '\0'); - return p != pend? p : NULL; + auto p_l = std::find(this->p, pend, '\0'); + return p_l != pend? p_l : NULL; + } + + bool at_eol() const { + return p < pend && '\n' == pend[-1]; + } + const char * optional_eol() const { + return at_eol() ? "" : "\n"; } }; struct replace_t { struct span_t before, after; - replace_t( span_t before = span_t(), - span_t after = span_t() ) + replace_t() : before(span_t()), after(span_t()) {} + replace_t( span_t before, span_t after ) : before(before), after(after) {} replace_t& reset() { diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index cecdd22..fae96ed 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -45,6 +45,7 @@ }; enum accept_func_t { + accept_e, accept_done_e, accept_command_line_e, accept_envar_e, @@ -188,14 +189,14 @@ data_category_t category; category_map_t replacement; - init_statement_t( category_map_t replacement ) + explicit init_statement_t( const category_map_t& replacement ) : to_value(false) , category(data_category_none) , replacement(replacement) {} - init_statement_t( bool to_value = false ) + explicit init_statement_t( bool to_value = false ) : to_value(to_value) , category(data_category_none) , replacement(category_map_t()) @@ -242,7 +243,7 @@ struct Elem_list_t { std::list<E> elems; Elem_list_t() {} - Elem_list_t( E elem ) { + explicit Elem_list_t( E elem ) { elems.push_back(elem); } Elem_list_t * push_back( E elem ) { @@ -349,7 +350,7 @@ %token <string> SECTION %token <number> STANDARD_ALPHABET "STANDARD ALPHABET" %token <string> SWITCH -%token <string> UPSI +%token <string> UPSI %token <number> ZERO /* environment names */ @@ -375,7 +376,7 @@ LSUB "(" PARAMETER_kw "PARAMETER" OVERRIDE READY RESET - RSUB ")" + RSUB")" SERVICE_RELOAD "SERVICE RELOAD" STAR_CBL "*CBL" SUBSCRIPT SUPPRESS TITLE TRACE USE @@ -385,7 +386,10 @@ CDF_EVALUATE ">>EVALUATE" CDF_WHEN ">>WHEN" CDF_END_EVALUATE ">>END-EVALUATE" + CALL_CONVENTION ">>CALL-CONVENTION" CALL_COBOL "CALL" CALL_VERBATIM "CALL (as C)" + CDF_PUSH ">>PUSH" CDF_POP ">>POP" + SOURCE_FORMAT ">>SOURCE FORMAT" IF THEN ELSE SENTENCE @@ -399,7 +403,10 @@ STRING_kw "STRING" STOP SUBTRACT START UNSTRING WRITE WHEN - ABS ACCESS ACOS ACTUAL ADVANCING AFTER ALL + ARGUMENT_NUMBER ARGUMENT_VALUE + ENVIRONMENT_NAME ENVIRONMENT_VALUE + + ABS ACCESS ACOS ACTUAL ADVANCING AFTER ALL ALLOCATE ALPHABET ALPHABETIC ALPHABETIC_LOWER "ALPHABETIC-LOWER" ALPHABETIC_UPPER "ALPHABETIC-UPPER" @@ -662,7 +669,7 @@ %type <boolean> all optional sign_leading on_off initialized strong is_signed %type <number> count data_clauses data_clause %type <number> nine nines nps relop spaces_etc reserved_value signed -%type <number> variable_type +%type <number> variable_type binary_type %type <number> true_false posneg eval_posneg %type <number> open_io alphabet_etc %type <special_type> device_name @@ -692,7 +699,7 @@ %type <string> fd_name picture_sym name66 paragraph_name %type <literal> literalism %type <number> bound advance_when org_clause1 read_next -%type <number> access_mode multiple lock_how lock_mode +%type <number> access_mode multiple lock_how lock_mode org_is %type <select_clauses> select_clauses %type <select_clause> select_clause access_clause alt_key_clause assign_clause collate_clause status_clause @@ -732,7 +739,7 @@ %type <refer> inspected %type <insp_qual> insp_qual -%type <insp_match> insp_quals insp_mtquals tally_match +%type <insp_match> insp_quals insp_mtqual tally_match %type <insp_replace> x_by_y %type <insp_oper> replace_oper x_by_ys %type <insp_oper> tally_forth tally_matches @@ -793,6 +800,8 @@ %type <error_clauses> io_invalids read_eofs write_eops %type <boolean> io_invalid read_eof write_eop global is_global anycase backward + end_display + exh_changed exh_named %type <number> mistake globally first_last %type <io_mode> io_mode @@ -831,6 +840,9 @@ %type <opt_arith> opt_arith_type %type <module_type> module_type +%type <nameloc> repo_func_name +%type <namelocs> repo_func_names + %union { bool boolean; int number; @@ -840,10 +852,12 @@ cbl_field_attr_t field_attr; ec_type_t ec_type; ec_list_t* ec_list; + cbl_nameloc_t *nameloc; + cbl_namelocs_t *namelocs; declarative_list_t* dcl_list_t; isym_list_t* isym_list; struct { radix_t radix; char *string; } numstr; - struct { int token; literal_t name; } prog_end; + struct { YYLTYPE loc; int token; literal_t name; } prog_end; struct { int token; special_name_t id; } special_type; struct { cbl_field_type_t type; uint32_t capacity; bool signable; } computational; @@ -880,9 +894,9 @@ struct arith_t *arith; struct { size_t ntgt; cbl_num_result_t *tgts; cbl_refer_t *expr; } compute_body_t; - struct ast_inspect_t *insp_one; - struct ast_inspect_list_t *insp_all; - struct ast_inspect_oper_t *insp_oper; + struct cbl_inspect_t *insp_one; + cbl_inspect_opers_t *insp_all; + struct cbl_inspect_oper_t *insp_oper; struct { bool before; cbl_inspect_qual_t *qual; } insp_qual; cbl_inspect_t *inspect; cbl_inspect_match_t *insp_match; @@ -897,7 +911,7 @@ struct refer_pair_t { cbl_refer_t *first, *second; } refer2; struct { refer_collection_t *inputs; refer_pair_t into; } str_body; - struct { accept_func_t func; cbl_refer_t *into, *from; } accept_func; + struct { accept_func_t func; cbl_refer_t *into, *from; special_name_t special;} accept_func; struct unstring_into_t *uns_into; struct unstring_tgt_list_t *uns_tgts; struct unstring_tgt_t *uns_tgt; @@ -951,7 +965,7 @@ %printer { fprintf(yyo, "%s'%.*s'{" HOST_SIZE_T_PRINT_UNSIGNED "} %s", $$.prefix, int($$.len), $$.data, (fmt_size_t)$$.len, $$.symbol_name()); } <literal> -%printer { fprintf(yyo, "%s (1st of " HOST_SIZE_T_PRINT_UNSIGNED ")", +%printer { fprintf(yyo,"%s (1st of" HOST_SIZE_T_PRINT_UNSIGNED")", $$->targets.empty()? "" : $$->targets.front().refer.field->name, (fmt_size_t)$$->targets.size() ); } <targets> %printer { fprintf(yyo, "#" HOST_SIZE_T_PRINT_UNSIGNED ": %s", @@ -999,7 +1013,9 @@ %right IF THEN ELSE SENTENCE ACCEPT ADD ALTER CALL CANCEL CLOSE COMPUTE CONTINUE - DELETE DISPLAY DIVIDE EVALUATE END EOP EXIT FILLER_kw + DELETE DISPLAY DIVIDE + EVALUATE END EOP EXIT + FILLER_kw GOBACK GOTO INITIALIZE INSPECT MERGE MOVE MULTIPLY OPEN OVERFLOW_kw PARAGRAPH PERFORM @@ -1320,7 +1336,7 @@ return ok; } - static void initialize_allocated( cbl_refer_t input ); + static void initialize_allocated( const cbl_refer_t& input ); static void initialize_statement( std::list<cbl_num_result_t>& tgts, bool with_filler, @@ -1346,8 +1362,16 @@ // more integer friendly. Any integer value that can be expressed in 1 // to MAX_FIXED_POINT_DIGITS digits is converted to a string without a // decimal point and no exponent. + char *pdot = strchr(psz, '.'); + gcc_assert(pdot); char *pe = strchr(psz, 'e'); + if( !pe ) + { + // The most likely cause of this is a "0.0" result. + strcpy(psz, "0"); + return; + } char *pnz = pe-1; while(*pnz == '0') { @@ -1445,21 +1469,22 @@ id_div: cdf_words IDENTIFICATION_DIV '.' program_id cdf_words: %empty | cobol_words + /* | error { error_msg(@1, "not a COBOL-WORD"); } */ ; cobol_words: cobol_words1 | cobol_words cobol_words1 ; cobol_words1: COBOL_WORDS EQUATE NAME[keyword] WITH NAME[name] { - if( ! tokens.equate(@keyword, $keyword, $name) ) { YYERROR; } + if( ! cdf_tokens.equate(@keyword, $keyword, $name) ) { YYERROR; } } | COBOL_WORDS UNDEFINE NAME[keyword] { - if( ! tokens.undefine(@keyword, $keyword) ) { YYERROR; } + if( ! cdf_tokens.undefine(@keyword, $keyword) ) { YYERROR; } } | COBOL_WORDS SUBSTITUTE NAME[keyword] BY NAME[name] { - if( ! tokens.substitute(@keyword, $keyword, $name) ) { YYERROR; } + if( ! cdf_tokens.substitute(@keyword, $keyword, $name) ) { YYERROR; } } | COBOL_WORDS RESERVE NAME[name] { - if( ! tokens.reserve(@name, $name) ) { YYERROR; } + if( ! cdf_tokens.reserve(@name, $name) ) { YYERROR; } } ; @@ -1473,7 +1498,7 @@ program_id: PROGRAM_ID dot namestr[name] program_as program_attrs[attr] dot const char *name = string_of($name); parser_enter_program( name, false, &main_error ); if( main_error ) { - error_msg(@name, "PROGRAM-ID 'main' is invalid with -main option"); + error_msg(@name, "PROGRAM-ID 'main' is invalid with %<-main%> option"); YYERROR; } @@ -1499,7 +1524,7 @@ program_as: %empty { static const literal_t empty {}; $$ = empty; } | AS LITERAL { $$ = $2; } ; -function_id: FUNCTION '.' NAME program_as program_attrs[attr] '.' +function_id: FUNCTION NAME program_as program_attrs[attr] '.' { internal_ebcdic_lock(); current_division = identification_div_e; @@ -1509,7 +1534,8 @@ function_id: FUNCTION '.' NAME program_as program_attrs[attr] '.' int main_error = 0; parser_enter_program( $NAME, true, &main_error ); if( main_error ) { - error_msg(@NAME, "FUNCTION-ID 'main' is invalid with -main option"); + error_msg(@NAME, "FUNCTION-ID %<main%> is invalid " + "with %<-main%> option"); YYERROR; } if( symbols_begin() == symbols_end() ) { @@ -1532,7 +1558,7 @@ function_id: FUNCTION '.' NAME program_as program_attrs[attr] '.' current.udf_add(current_program_index()); if( nparse_error > 0 ) YYABORT; } - | FUNCTION '.' NAME program_as is PROTOTYPE '.' + | FUNCTION NAME program_as is PROTOTYPE '.' { cbl_unimplemented("FUNCTION PROTOTYPE"); } @@ -1551,7 +1577,7 @@ opt_clause: opt_arith | opt_entry | opt_binary | opt_decimal { - cbl_unimplementedw("type FLOAT-DECIMAL was ignored"); + cbl_unimplemented("type FLOAT-DECIMAL"); } | opt_intermediate | opt_init @@ -1580,7 +1606,7 @@ opt_binary: FLOAT_BINARY default_kw is HIGH_ORDER_LEFT { cbl_unimplementedw("HIGH-ORDER-LEFT was ignored"); if( ! current.option_binary(cbl_options_t::high_order_left_e) ) { - error_msg(@3, "unable to set HIGH_ORDER_LEFT"); + error_msg(@3, "unable to set %<HIGH_ORDER_LEFT%>"); } } | FLOAT_BINARY default_kw is HIGH_ORDER_RIGHT[opt] @@ -1823,7 +1849,7 @@ select: SELECT optional NAME[name] select_clauses[clauses] '.' cbl_file_t *file = $clauses.file; file->optional = $optional; - file->line = yylineno; + file->line = @name.first_line; if( !namcpy(@clauses, file->name, $name) ) YYERROR; if( ! ($clauses.clauses & assign_clause_e) ) { @@ -1896,7 +1922,7 @@ select: SELECT optional NAME[name] select_clauses[clauses] '.' cbl_file_t file = protofile; file.optional = $optional; - file.line = yylineno; + file.line = @name.first_line; if( !namcpy(@name, file.name, $name) ) YYERROR; if( file_add(@name, &file) == NULL ) YYERROR; @@ -1940,7 +1966,7 @@ select_clauses: select_clause { $$.clauses = $1.clause; $$.file = $1.file; } if( $$.file->nkey++ == 0 ) { // If no key yet exists, create room for it and the // present alternate. - assert($$.file->keys == &cbl_file_t::no_key); + assert($$.file->keys == nullptr); $$.file->keys = new cbl_file_key_t[++$$.file->nkey]; } { @@ -1952,8 +1978,7 @@ select_clauses: select_clause { $$.clauses = $1.clause; $$.file = $1.file; } // Assign the alternate key to the last element, // and update the pointer. *alt = $part.file->keys[0]; - delete[] $$.file->keys; - $$.file->keys = keys; + $$.file->keys_update(keys); } break; case assign_clause_e: @@ -2022,11 +2047,11 @@ select_clauses: select_clause { $$.clauses = $1.clause; $$.file = $1.file; } YYERROR; } if( $$.file->nkey == 0 ) { + assert( 1 == $part.file->nkey ); $$.file->nkey = $part.file->nkey; - $$.file->keys = $part.file->keys; - } else { - $$.file->keys[0] = $part.file->keys[0]; - } + $$.file->keys = new cbl_file_key_t[1]; + } + $$.file->keys[0] = $part.file->keys[0]; break; /* case password_clause_e: */ case file_status_clause_e: @@ -2184,14 +2209,28 @@ org_clause: org_clause1[org] $$.file->org = static_cast<cbl_file_org_t>($org); } ; -org_is: %empty - | ORGANIZATION is +org_is: %empty { $$ = 0; } + | ORGANIZATION is { $$ = 0; } + | ORGANIZATION is RECORD { $$ = RECORD; } + | RECORD { $$ = RECORD; } ; // file_sequential is the proper default -org_clause1: org_is SEQUENTIAL { $$ = file_sequential_e; } - | org_is LINE SEQUENTIAL { $$ = file_line_sequential_e; } - | org_is RELATIVE { $$ = file_relative_e; } - | org_is INDEXED { $$ = file_indexed_e; } +org_clause1: org_is SEQUENTIAL { + $$ = $1 == RECORD? file_line_sequential_e : file_sequential_e; + } + | org_is LINE SEQUENTIAL + { + if( $1 ) error_msg(@2, "syntax error: invalid %<RECORD%>"); + $$ = file_line_sequential_e; + } + | org_is RELATIVE { + if( $1 ) error_msg(@2, "syntax error: invalid %<RECORD%>"); + $$ = file_relative_e; + } + | org_is INDEXED { + if( $1 ) error_msg(@2, "syntax error: invalid %<RECORD%>"); + $$ = file_indexed_e; + } ; /* @@ -2277,7 +2316,9 @@ config_paragraphs: config_paragraph config_paragraph: SPECIAL_NAMES '.' | SPECIAL_NAMES '.' specials '.' + | SOURCE_COMPUTER '.' | SOURCE_COMPUTER '.' NAME with_debug '.' + | OBJECT_COMPUTER '.' | OBJECT_COMPUTER '.' NAME collating_sequence[name] '.' { if( $name ) { @@ -2288,8 +2329,8 @@ config_paragraph: } } } - | REPOSITORY '.' - | REPOSITORY '.' repo_members '.' + | REPOSITORY dot + | REPOSITORY dot repo_members '.' ; repo_members: repo_member @@ -2317,38 +2358,61 @@ repo_expands: %empty repo_interface: INTERFACE NAME repo_as repo_expands ; -repo_func: FUNCTION repo_func_names INTRINSIC - { - auto namelocs( name_queue.pop() ); - for( const auto& nameloc : namelocs ) { - current.repository_add(nameloc.name); +repo_func: FUNCTION repo_func_names[namelocs] INTRINSIC { + for( const auto& nameloc : *$namelocs ) { + if( 0 == intrinsic_token_of(nameloc.name) ) { + error_msg(nameloc.loc, + "no such intrinsic function: %qs", + nameloc.name); + continue; + } + current.repository_add(nameloc.name); } } | FUNCTION ALL INTRINSIC { current.repository_add_all(); } - | FUNCTION repo_func_names - ; -repo_func_names: - repo_func_name - | repo_func_names repo_func_name - ; -repo_func_name: NAME { - if( ! current.repository_add($NAME) ) { // add intrinsic by name - auto token = current.udf_in($NAME); + | FUNCTION repo_func_names[namelocs] { + // We allow multiple names because GnuCOBOL does. ISO says 1. + for( const auto& nameloc : *$namelocs ) { + if( 0 != intrinsic_token_of(nameloc.name) ) { + error_msg(nameloc.loc, + "intrinsic function %qs requires INTRINSIC", + nameloc.name); + continue; + } + auto token = current.udf_in(nameloc.name); if( !token ) { - error_msg(@NAME, "%s is not defined here as a user-defined function", - $NAME); - current.udf_dump(); - YYERROR; + error_msg(nameloc.loc, + "%s is not defined here as a user-defined function", + nameloc.name); + continue; } - auto e = symbol_function(0, $NAME); + auto e = symbol_function(0, nameloc.name); assert(e); current.repository_add(symbol_index(e)); // add UDF to repository } } ; +repo_func_names: + repo_func_name[name] { + $$ = new cbl_namelocs_t(1, *$name); + delete $name; + } + | repo_func_names repo_func_name[name] { + $$ = $1; + $$->push_back(*$name); + delete $name; + } + ; +repo_func_name: NAME repo_as { + if( ! $repo_as.empty() ) { + cbl_unimplemented_at(@repo_as, "%qs", $repo_as.data); + } + $$ = new cbl_nameloc_t(@NAME, $NAME); + } + ; repo_program: PROGRAM_kw NAME repo_as { @@ -2380,7 +2444,7 @@ repo_program: PROGRAM_kw NAME repo_as assert(program); prog.data.initial = program->name; } - auto e = symbol_field_add(PROGRAM, &prog); + const auto e = symbol_field_add(PROGRAM, &prog); symbol_field_location(symbol_index(e), @NAME); } ; @@ -2420,7 +2484,7 @@ special_name: dev_mnemonic | CLASS NAME is domains { struct cbl_field_t field = { 0, - FldClass, FldInvalid, 0, 0, 0, 0, nonarray, yylineno, "", + FldClass, FldInvalid, 0, 0, 0, 0, nonarray, @NAME.first_line, "", 0, cbl_field_t::linkage_t(), {}, NULL }; if( !namcpy(@NAME, field.name, $2) ) YYERROR; @@ -2510,7 +2574,7 @@ dev_mnemonic: device_name is NAME { auto p = cmd_or_env_special_of($device); if( !p ) { - error_msg(@device, "%s is not a device name"); + error_msg(@device, "%s is not a device name", $device); YYERROR; } @@ -2551,6 +2615,10 @@ device_name: SYSIN { $$.token = SYSIN; $$.id = SYSIN_e; } | STDIN { $$.token = STDIN; $$.id = STDIN_e; } | STDOUT { $$.token = STDOUT; $$.id = STDOUT_e; } | STDERR { $$.token = STDERR; $$.id = STDERR_e; } + /* These cannot be both ctx_name and here. * + /* ARGUMENT_NUMBER { $$.token=0; $$.id = ARG_NUM_e; } */ + /* ENVIRONMENT_NAME { $$.token=0; $$.id = ENV_NAME_e; } */ + /* ENVIRONMENT_VALUE { $$.token=0; $$.id = ENV_VALUE_e; } */ ; alphabet_name: STANDARD_ALPHABET { $$ = alphabet_add(@1, ASCII_e); } @@ -2582,7 +2650,8 @@ alphabet_seqs: alphabet_seq[seq] YYERROR; } $$->add_sequence(@seq, $seq.low); - size_t len = $seq.low == nul_string()? 1 : strlen((const char*)$seq.low); + size_t len = $seq.low == nul_string()? + 1 : strlen((const char*)$seq.low); assert(len > 0); $$->add_interval(@seq, $seq.low[--len], $seq.high[0]); $$->add_sequence(@seq, $seq.high); @@ -2635,17 +2704,19 @@ alphabet_seq: alphabet_lit[low] alphabet_etc: alphabet_lit { if( $1.len > 1 ) { - error_msg(@1, "'%c' can be only a single letter", $1.data); + error_msg(@1, "%qs can be only a single letter", $1.data); YYERROR; } $$ = (unsigned char)$1.data[0]; } | spaces_etc { - // For figurative constants, pass the synmbol table index, + // For figurative constants, pass the symbol table index, // marked with the high bit. static const auto bits = sizeof($$) * 8 - 1; - $$ = 1; - $$ = $$ << bits; + unsigned int high_bit = 1L << bits; + static_assert(sizeof($$) == sizeof(high_bit), + "adjust high_bit to match size of nonterminal target"); + memcpy(&$$, &high_bit, sizeof($$)); $$ |= constant_index($1); } ; @@ -2819,7 +2890,7 @@ domain: all LITERAL[a] if( ! string_of($value) ) { yywarn("'%s' has embedded NUL", $value.data); } - char *dom = $value.data; + const char *dom = $value.data; $$ = new cbl_domain_t(@value, false, $value.len, dom); } | when_set_to FALSE_kw is reserved_value @@ -2899,7 +2970,7 @@ fd_clause: record_desc f->varying_size.explicitly = f->varies(); if( f->varying_size.max != 0 ) { if( !(f->varying_size.min <= f->varying_size.max) ) { - error_msg(@1, "%zu must be <= %zu", + error_msg(@1, "%zu must be less than or equal to %zu", f->varying_size.min, f->varying_size.max); YYERROR; } @@ -2938,9 +3009,9 @@ fd_clause: record_desc { auto f = cbl_file_of(symbol_at(file_section_fd)); f->attr |= external_e; - cbl_unimplemented("AS LITERAL "); + cbl_unimplemented("AS LITERAL"); } - | fd_linage + | fd_linage { cbl_unimplemented("LINAGE"); } | fd_report { cbl_unimplemented("REPORT WRITER"); YYERROR; @@ -2975,7 +3046,7 @@ rec_contains: NUMSTR[min] { } $$.max = n; if( !($$.min < $$.max) ) { - error_msg(@max, "FROM (%xz) must be less than TO (%zu)", + error_msg(@max, "FROM (%zu) must be less than TO (%zu)", $$.min, $$.max); YYERROR; } @@ -3108,7 +3179,7 @@ depending: %empty assert(e->type == SymField); odo = symbol_index(e); } else { - e = symbol_field_forward_add(PROGRAM, 0, $NAME, yylineno); + e = symbol_field_forward_add(PROGRAM, 0, $NAME, @NAME.first_line); if( !e ) YYERROR; symbol_field_location( symbol_index(e), @NAME ); odo = field_index(cbl_field_of(e)); @@ -3171,7 +3242,7 @@ field: cdf } initial = string_of(field.data.value_of()); if( !initial ) { - error_msg(@1, xstrerror(errno)); + error_msg(@1, "could not convert value to string"); YYERROR; } char decimal = symbol_decimal_point(); @@ -3279,9 +3350,9 @@ index_field1: ctx_name[name] auto symbol = symbol_field(PROGRAM, field.parent, $name); if( symbol ) { - auto field( cbl_field_of(symbol) ); + auto f( cbl_field_of(symbol) ); error_msg(@name, "'%s' already defined on line %d", - field->name, field->line ); + f->name, f->line ); YYERROR; } @@ -3308,7 +3379,7 @@ level_name: LEVEL ctx_name } struct cbl_field_t field = { 0, FldInvalid, FldInvalid, 0, 0, 0, capacity_cast($1), - nonarray, yylineno, "", + nonarray, @ctx_name.first_line, "", 0, cbl_field_t::linkage_t(), {}, NULL }; if( !namcpy(@ctx_name, field.name, $2) ) YYERROR; @@ -3333,7 +3404,7 @@ level_name: LEVEL ctx_name } struct cbl_field_t field = { 0, FldInvalid, FldInvalid, 0, 0, 0, capacity_cast($1), - nonarray, yylineno, "", + nonarray, @LEVEL.first_line, "", 0, {}, {}, NULL }; $$ = field_add(@1, &field); @@ -3352,9 +3423,11 @@ data_descr: data_descr1 ; const_value: cce_expr - | BYTE_LENGTH of name { $name->data.set_real_from_capacity(&$$); } - | LENGTH of name { $name->data.set_real_from_capacity(&$$); } - | LENGTH_OF of name { $name->data.set_real_from_capacity(&$$); } + | BYTE_LENGTH of name { set_real_from_capacity(@name, $name, &$$); } + | LENGTH of name { set_real_from_capacity(@name, $name, &$$); } + | LENGTH_OF of name { set_real_from_capacity(@name, $name, &$$); } + | LENGTH_OF of binary_type[type] { + real_from_integer(&$$, VOIDmode, $type, SIGNED); } ; value78: literalism @@ -3370,6 +3443,12 @@ value78: literalism data = build_real (float128_type_node, $1); $$ = new cbl_field_data_t(data); } + | reserved_value[value] + { + const auto field = constant_of(constant_index($value)); + $$ = new cbl_field_data_t(field->data); + } + | true_false { cbl_unimplemented("Boolean constant"); @@ -3403,6 +3482,21 @@ data_descr1: level_name error_msg(@1, "%s was defined by CDF", field.name); } } + + | level_name CONSTANT is_global as reserved_value[value] + { + cbl_field_t& field = *$1; + if( field.level != 1 ) { + error_msg(@1, "%s must be an 01-level data item", field.name); + YYERROR; + } + field.attr |= constant_e; + if( $is_global ) field.attr |= global_e; + field.type = FldLiteralA; + auto fig = constant_of(constant_index($value)); + field.data = fig->data; + } + | level_name CONSTANT is_global as literalism[lit] { cbl_field_t& field = *$1; @@ -3442,13 +3536,13 @@ data_descr1: level_name | LEVEL78 NAME[name] VALUE is value78[data] { - if( ! dialect_mf() ) { - dialect_error(@1, "level 78", "mf"); + if( ! (dialect_mf() || dialect_gnu()) ) { + dialect_error(@1, "level 78", "mf or gnu"); YYERROR; } struct cbl_field_t field = { 0, FldLiteralA, FldInvalid, constant_e, 0, 0, 78, nonarray, - yylineno, "", 0, {}, *$data, NULL }; + @name.first_line, "", 0, {}, *$data, NULL }; if( !namcpy(@name, field.name, $name) ) YYERROR; if( field.data.initial ) { field.attr |= quoted_e; @@ -3471,7 +3565,7 @@ data_descr1: level_name | LEVEL88 NAME /* VALUE */ NULLPTR { struct cbl_field_t field = { 0, - FldClass, FldInvalid, 0, 0, 0, 88, nonarray, yylineno, "", + FldClass, FldInvalid, 0, 0, 0, 88, nonarray, @NAME.first_line, "", 0, cbl_field_t::linkage_t(), {}, NULL }; if( !namcpy(@NAME, field.name, $2) ) YYERROR; @@ -3497,7 +3591,7 @@ data_descr1: level_name | LEVEL88 NAME VALUE domains { struct cbl_field_t field = { 0, - FldClass, FldInvalid, 0, 0, 0, 88, nonarray, yylineno, "", + FldClass, FldInvalid, 0, 0, 0, 88, nonarray, @NAME.first_line, "", 0, cbl_field_t::linkage_t(), {}, NULL }; if( !namcpy(@NAME, field.name, $2) ) YYERROR; @@ -3602,7 +3696,7 @@ data_descr1: level_name } if( field_index($thru) <= field_index($orig) ) { error_msg(@orig, "cannot RENAME %s %s THRU %s %s " - "because they're in the wrong order", + "because they are in the wrong order", $orig->level_str(), name_of($orig), $thru->level_str(), name_of($thru)); YYERROR; @@ -3644,7 +3738,7 @@ data_descr1: level_name case FldNumericEdited: if( $field->has_attr(signable_e) ) { error_msg(@2, "%s has 'S' in PICTURE, cannot be BLANK WHEN ZERO", - $field->name, cbl_field_type_str($field->type) ); + $field->name ); } break; default: @@ -3722,7 +3816,7 @@ data_descr1: level_name $field->report_invalid_initial_value(@data_clauses); // verify REDEFINES - auto parent = parent_of($field); + const auto parent = parent_of($field); if( parent && $field->level == parent->level ) { valid_redefine(@field, $field, parent); // calls yyerror } @@ -3855,10 +3949,10 @@ data_clauses: data_clause auto redefined = symbol_redefines(field); if( redefined && redefined->type == FldPointer ) { if( yydebug ) { - yywarn("expanding %s size from %u bytes to %zu " - "because it redefines %s with USAGE POINTER", + yywarn("expanding %s size from %u bytes to %wd " + "because it redefines %s with %<USAGE POINTER%>", field->name, field->size(), - (size_t)int_size_in_bytes(ptr_type_node), + int_size_in_bytes(ptr_type_node), redefined->name); } field->embiggen(); @@ -3949,7 +4043,7 @@ picture_clause: PIC signed nps[fore] nines nps[aft] field->data.capacity = type_capacity(field->type, $4); field->data.digits = $4; if( long(field->data.digits) != $4 ) { - error_msg(@2, "indicated size would be %ld bytes, " + error_msg(@2, "indicated size would be %d bytes, " "maximum data item size is %u", $4, UINT32_MAX); } @@ -4015,15 +4109,16 @@ picture_clause: PIC signed nps[fore] nines nps[aft] cbl_field_t *field = current_field(); if( field->type == FldNumericBin5 && - field->data.capacity == 0 && - dialect_mf() ) + field->data.capacity == 0xFF && + (dialect_gnu() || dialect_mf()) ) { // PIC X COMP-X or COMP-9 if( ! field->has_attr(all_x_e) ) { - error_msg(@2, "COMP PICTURE requires all X's or all 9's"); + error_msg(@2, "COMP PICTURE requires all X%'s or all 9%'s"); YYERROR; } } else { if( !field_type_update(field, FldAlphanumeric, @$) ) { + dbgmsg("alnum_pic: %s", field_str(field)); YYERROR; } } @@ -4053,7 +4148,7 @@ picture_clause: PIC signed nps[fore] nines nps[aft] } ERROR_IF_CAPACITY(@PIC, field); if( !is_numeric_edited($picture) ) { - error_msg(@picture, numed_message); + error_msg(@picture, "%s", numed_message); YYERROR; } field->data.picture = $picture; @@ -4132,7 +4227,7 @@ alphanum_part: ALNUM[picture] count $$.nbyte += count; // AX9(3) has count 5 } if( count < 0 ) { - error_msg(@2, "PICTURE count '(%d)' is negative", count ); + error_msg(@2, "PICTURE count %<(%d)%> is negative", count ); YYERROR; } } @@ -4151,7 +4246,7 @@ nine: %empty { $$ = 0; } { $$ = $1; if( $$ == 0 ) { - error_msg(@1, "'(0)' invalid in PICTURE (ISO 2023 13.18.40.3)"); + error_msg(@1, "%<(0)%> invalid in PICTURE (ISO 2023 13.18.40.3)"); } } ; @@ -4165,14 +4260,14 @@ count: %empty { $$ = 0; } REAL_VALUE_TYPE rn = numstr2i($NUMSTR.string, $NUMSTR.radix); $$ = real_to_integer (&rn); if( $$ == 0 ) { - error_msg(@2, "'(0)' invalid in PICTURE (ISO 2023 13.18.40.3)"); + error_msg(@2, "%<0%> invalid in PICTURE (ISO 2023 13.18.40.3)"); } } | '(' NAME ')' { auto value = cdf_value($NAME); if( ! (value && value->is_numeric()) ) { - error_msg(@NAME, "PICTURE '(%s)' requires a CONSTANT value", $NAME ); + error_msg(@NAME, "PICTURE %qs requires a CONSTANT value", $NAME ); YYERROR; } int nmsg = 0; @@ -4185,13 +4280,13 @@ count: %empty { $$ = 0; } if( !real_identical (TREE_REAL_CST_PTR (field->data.value_of()), &vi) ) { nmsg++; - error_msg(@NAME, "invalid PICTURE count '(%s)'", + error_msg(@NAME, "invalid PICTURE count %<(%s)%>", field->data.initial ); } } $$ = value->as_number(); if( $$ <= 0 && !nmsg) { - error_msg(@NAME, "invalid PICTURE count '(%s)'", $NAME ); + error_msg(@NAME, "invalid PICTURE count %<(%s)%>", $NAME ); } } ; @@ -4240,21 +4335,21 @@ usage_clause1: usage BIT case FldAlphanumeric: // PIC X COMP-5 or COMP-X assert( field->data.digits == 0 ); assert( field->data.rdigits == 0 ); - if( dialect_mf() ) { + if( (dialect_mf() || dialect_gnu()) ) { field->type = $comp.type; field->clear_attr(signable_e); } else { error_msg(@comp, "numeric USAGE invalid " "with Alpnanumeric PICTURE"); - dialect_error(@1, "Alpnanumeric COMP-5 or COMP-X", "mf"); + dialect_error(@1, "Alpnanumeric COMP-5 or COMP-X", "mf or gnu"); YYERROR; } break; case FldNumericDisplay: // PIC 9 COMP-5 or COMP-X if( $comp.capacity == 0xFF ) { // comp-x is a bit like comp-5 assert( field->data.digits == field->data.capacity ); - if( ! dialect_mf() ) { - dialect_error(@1, "COMP-X", "mf"); + if( ! (dialect_mf() || dialect_gnu()) ) { + dialect_error(@1, "COMP-X", "mf or gnu"); } } field->type = $comp.type; @@ -4321,21 +4416,21 @@ usage_clause1: usage BIT case FldAlphanumeric: // PIC X COMP-5 or COMP-X assert( field->data.digits == 0 ); assert( field->data.rdigits == 0 ); - if( dialect_mf() ) { + if( (dialect_mf() || dialect_gnu()) ) { field->type = $comp.type; field->clear_attr(signable_e); } else { error_msg(@comp, "numeric USAGE invalid " "with Alpnanumeric PICTURE"); - dialect_error(@1, "Alpnanumeric COMP-5 or COMP-X", "mf"); + dialect_error(@1, "Alpnanumeric COMP-5 or COMP-X", "mf or gnu"); YYERROR; } break; case FldNumericDisplay: // PIC 9 COMP-5 or COMP-X if( $comp.capacity == 0xFF ) { // comp-x is a bit like comp-5 assert( field->data.digits == field->data.capacity ); - if( ! dialect_mf() ) { - dialect_error(@1, "COMP-X", "mf"); + if( ! (dialect_mf() || dialect_gnu()) ) { + dialect_error(@1, "COMP-X", "mf or gnu"); } } field->type = $comp.type; @@ -4526,7 +4621,7 @@ justified_clause: is JUSTIFIED redefines_clause: REDEFINES NAME[orig] { - struct symbol_elem_t *e = field_of($orig); + struct symbol_elem_t *e = symbol_field(PROGRAM, 0, $orig); if( !e ) { error_msg(@2, "REDEFINES target not defined"); YYERROR; @@ -4662,7 +4757,7 @@ same_clause: SAME AS name YYERROR; } - auto e = symbol_field_same_as( field, other ); + const auto e = symbol_field_same_as( field, other ); symbol_field_location( symbol_index(e), @name ); } ; @@ -4711,7 +4806,7 @@ type_clause: TYPE to typename { cbl_field_t *field = current_field(); if( $typename ) { - auto e = symbol_field_same_as(field, $typename); + const auto e = symbol_field_same_as(field, $typename); symbol_field_location( symbol_index(e), @typename ); } } @@ -4723,7 +4818,7 @@ type_clause: TYPE to typename } cbl_field_t *field = current_field(); if( $typename ) { - auto e = symbol_field_same_as(field, $typename); + const auto e = symbol_field_same_as(field, $typename); symbol_field_location( symbol_index(e), @typename ); } } @@ -4826,6 +4921,7 @@ by_value_arg: scalar declaratives: %empty | DECLARATIVES '.' <label>{ + cbl_enabled_exceptions_t& enabled_exceptions( cdf_enabled_exceptions() ); current.enabled_exception_cache = enabled_exceptions; enabled_exceptions.clear(); current.doing_declaratives(true); @@ -4844,6 +4940,7 @@ declaratives: %empty * forward reference, because we haven't yet begun to parse * nondeclarative procedures. */ + cbl_enabled_exceptions_t& enabled_exceptions( cdf_enabled_exceptions() ); parser_label_label($label); enabled_exceptions = current.enabled_exception_cache; current.enabled_exception_cache.clear(); @@ -4936,12 +5033,11 @@ statements: statement { $$ = $1; } statement: error { if( current.declarative_section_name() ) { - error_msg(@1, "missing END DECLARATIVES or SECTION name", - nparse_error); + error_msg(@1, "missing END DECLARATIVES or SECTION name"); YYABORT; } if( max_errors_exceeded(nparse_error) ) { - error_msg(@1, "max errors %d reached", nparse_error); + error_msg(@1, "max errors %zu reached", nparse_error); YYABORT; } } @@ -4959,6 +5055,7 @@ statement: error { | divide { $$ = DIVIDE; } | entry { $$ = ENTRY; } | evaluate { $$ = EVALUATE; } + | exhibit_stmt { $$ = EXHIBIT; } | exit { $$ = EXIT; } | free { $$ = FREE; } | go_to { $$ = GOTO; } @@ -4989,9 +5086,8 @@ statement: error { /* * ISO defines ON EXCEPTION only for Format 3 (screen). We - * implement extensions defined by MF and Fujitsu (and us) to - * use ACCEPT to interact with the command line and the - * environment. + * implement extensions defined by MF and Fujitsu to use ACCEPT + * to interact with the command line and the environment. * * ISO ACCEPT and some others are implemented in accept_body, * before the parser sees any ON EXCEPTION. In those cases @@ -5006,6 +5102,9 @@ accept: accept_body end_accept { switch( $accept_body.func ) { case accept_done_e: break; + case accept_e: + parser_accept(*$1.into, $1.special, nullptr, nullptr); + break; case accept_command_line_e: if( $1.from->field == NULL ) { // take next command-line arg parser_accept_command_line(*$1.into, argi, NULL, NULL); @@ -5027,7 +5126,10 @@ accept: accept_body end_accept { switch( $accept_body.func ) { case accept_done_e: error_msg(@ec, "ON EXCEPTION valid only " - "with ENVIRONMENT or COMAMND-LINE(n)"); + "with ENVIRONMENT or COMMAND-LINE(n)"); + break; + case accept_e: + parser_accept(*$1.into, $1.special, $ec.on_error, $ec.not_error); break; case accept_command_line_e: if( $1.from->field == NULL ) { // take next command-line arg @@ -5039,7 +5141,7 @@ accept: accept_body end_accept { parser_move(*$1.into, *$1.from); if( $ec.on_error || $ec.not_error ) { error_msg(@ec, "ON EXCEPTION valid only " - "with ENVIRONMENT or COMAMND-LINE(n)"); + "with ENVIRONMENT or COMMAND-LINE(n)"); } } else { parser_accept_command_line(*$1.into, *$1.from, @@ -5060,7 +5162,7 @@ end_accept: %empty %prec ACCEPT accept_body: accept_refer { $$.func = accept_done_e; - parser_accept(*$1, CONSOLE_e); + parser_accept(*$1, CONSOLE_e, nullptr, nullptr); } | accept_refer FROM DATE { @@ -5119,29 +5221,15 @@ accept_body: accept_refer } | accept_refer FROM acceptable { - cbl_field_t *argc = register_find("_ARGI"); - switch( $acceptable->id ) { - case ARG_NUM_e: - $$.func = accept_command_line_e; - $$.into = $1; - $$.from = new_reference(argc); - break; - case ARG_VALUE_e: - $$.func = accept_command_line_e; - $$.into = $1; - $$.from = cbl_refer_t::empty(); - break; - default: - $$.func = accept_done_e; - parser_accept( *$1, $acceptable->id ); - } + $$.func = accept_e; + $$.into = $1; + $$.special = $acceptable->id; } | accept_refer FROM ENVIRONMENT envar { $$.func = accept_envar_e; $$.into = $1; $$.from = $envar; - //// parser_accept_envar( *$1, *$envar ); } | accept_refer FROM COMMAND_LINE { @@ -5153,7 +5241,6 @@ accept_body: accept_refer $$.func = accept_command_line_e; $$.into = $1; $$.from = $expr; - //// parser_accept_command_line(*$1, $expr->field ); } | accept_refer FROM COMMAND_LINE_COUNT { $$.func = accept_done_e; @@ -5206,7 +5293,7 @@ accept_except: EXCEPTION { $$.not_error = NULL; $$.on_error = label_add(LblArith, - uniq_label("accept"), yylineno); + uniq_label("accept"), @1.first_line); if( !$$.on_error ) YYERROR; parser_accept_exception( $$.on_error ); @@ -5236,9 +5323,58 @@ acceptable: device_name { $$ = special_of($1); if( !$$ ) { - error_msg(@NAME, "no such environment mnemonic name: %s", $NAME); - YYERROR; - } + const special_name_t *special_type = cmd_or_env_special_of($NAME); + if( !special_type ) { + error_msg(@NAME, "no such special name '%s'", $NAME); + YYERROR; + } + if( ENV_NAME_e == *special_type ) { + error_msg(@NAME, "cannot ACCEPT FROM %qs", $NAME); + YYERROR; + } + // Add the name now, as a convenience. + int token = 0; + switch(*special_type) { + case ARG_NUM_e: token = ARGUMENT_NUMBER; break; + case ARG_VALUE_e: token = ARGUMENT_VALUE; break; + case ENV_VALUE_e: token = ENVIRONMENT_VALUE; break; + + case ENV_NAME_e: + default: + error_msg(@NAME, "cannot ACCEPT FROM %qs", $NAME); + YYERROR; + break; + } + cbl_special_name_t special = { token, *special_type }; + namcpy(@NAME, special.name, $NAME); + + symbol_elem_t *e = symbol_special_add(PROGRAM, &special); + $$ = cbl_special_name_of(e); + cbl_special_name_t& unused(*$$); + assert(unused.id); + } + assert($$); + } + | ENVIRONMENT_VALUE { + // Add the name now, as a convenience. + cbl_special_name_t special = + { ENVIRONMENT_VALUE, ENV_VALUE_e, "ENVIRONMENT-VALUE" }; + symbol_elem_t *e = symbol_special_add(PROGRAM, &special); + $$ = cbl_special_name_of(e); + } + | ARGUMENT_NUMBER { + // Add the name now, as a convenience. + cbl_special_name_t special = + { ARGUMENT_NUMBER, ARG_NUM_e, "ARGUMENT-NUMBER" }; + symbol_elem_t *e = symbol_special_add(PROGRAM, &special); + $$ = cbl_special_name_of(e); + } + | ARGUMENT_VALUE { + // Add the name now, as a convenience. + cbl_special_name_t special = + { ARGUMENT_VALUE, ARG_VALUE_e, "ARGUMENT-VALUE" }; + symbol_elem_t *e = symbol_special_add(PROGRAM, &special); + $$ = cbl_special_name_of(e); } ; @@ -5355,16 +5491,13 @@ name88: NAME88 { scalar88: name88 subscripts[subs] refmod[ref] { - size_t n = $subs->size(); - auto subscripts = new cbl_refer_t[n]; - $subs->use_list(subscripts); if( $ref.from->is_reference() || $ref.len->is_reference() ) { error_msg(@subs, "subscripts on start:len refmod " "parameters are unsupported"); YYERROR; } cbl_span_t span( $ref.from, $ref.len ); - $$ = new cbl_refer_t($1, n, subscripts, span); + $$ = new cbl_refer_t($1, $subs->vectorize(), span); } | name88 refmod[ref] { @@ -5393,7 +5526,7 @@ allocate: ALLOCATE expr[size] CHARACTERS initialized RETURNING scalar[retu { statement_begin(@1, ALLOCATE); if( $size->field->type == FldLiteralN ) { - auto size = TREE_REAL_CST_PTR ($size->field->data.value_of()); + const auto size = TREE_REAL_CST_PTR ($size->field->data.value_of()); if( real_isneg(size) || real_iszero(size) ) { error_msg(@size, "size must be greater than 0"); YYERROR; @@ -5472,46 +5605,18 @@ compute_expr: '=' { } ; -display: disp_body end_display +display: disp_body end_display[advance] { - std::vector <cbl_refer_t> args($1.vargs->args.size()); - std::copy( $1.vargs->args.begin(), $1.vargs->args.end(), args.begin() ); - if( $1.special && $1.special->id == ARG_NUM_e ) { - if( $1.vargs->args.size() != 1 ) { - error_msg(@1, "ARGUMENT-NUMBER can be set to only one value"); - } - cbl_refer_t& src( $1.vargs->args.front() ); - cbl_field_t *dst = register_find("_ARGI"); - parser_move( dst, src ); - } else { - parser_display($1.special, - args.empty()? NULL : args.data(), args.size(), - DISPLAY_ADVANCE); - } - current.declaratives_evaluate(); - } - | disp_body NO ADVANCING end_display - { - std::vector <cbl_refer_t> args($1.vargs->args.size()); - std::copy( $1.vargs->args.begin(), $1.vargs->args.end(), args.begin() ); - - if( $1.special && $1.special->id == ARG_NUM_e ) { - if( $1.vargs->args.size() != 1 ) { - error_msg(@1, "ARGUMENT-NUMBER can be set to only one value"); - } - cbl_refer_t& src( $1.vargs->args.front() ); - cbl_field_t *dst = register_find("_ARGI"); - parser_move( dst, src ); - } else { - parser_display($1.special, - args.empty()? NULL : args.data(), args.size(), - DISPLAY_NO_ADVANCE); - } + std::vector <cbl_refer_t> args($1.vargs->args.begin(), + $1.vargs->args.end()); + parser_display($1.special, args, $advance); current.declaratives_evaluate(); } ; -end_display: %empty - | END_DISPLAY +end_display: %empty { $$ = DISPLAY_ADVANCE; } + | END_DISPLAY { $$ = DISPLAY_ADVANCE; } + | NO ADVANCING { $$ = DISPLAY_NO_ADVANCE; } + | NO ADVANCING END_DISPLAY { $$ = DISPLAY_NO_ADVANCE; } ; disp_body: disp_vargs[vargs] { @@ -5542,14 +5647,62 @@ disp_upon: device_name { error_msg(@NAME, "no such special name '%s'", $NAME); YYERROR; } - // Add the name now, as a convenience. - cbl_special_name_t special = { 0, *special_type }; + // Add the name now, as a convenience. + // These may come through as a NAME, depending on how scanned. + int token = 0; + switch(*special_type) { + case ARG_NUM_e: token = ARGUMENT_NUMBER; break; + case ENV_NAME_e: token = ENVIRONMENT_NAME; break; + case ENV_VALUE_e: token = ENVIRONMENT_VALUE; break; + + case ARG_VALUE_e: + default: + error_msg(@NAME, "cannot DISPLAY UPON %qs", $NAME); + YYERROR; + break; + } + cbl_special_name_t special = { token, *special_type }; namcpy(@NAME, special.name, $NAME); e = symbol_special_add(PROGRAM, &special); } $$ = cbl_special_name_of(e); } + | ARGUMENT_NUMBER { + // Add the name now, as a convenience. + cbl_special_name_t special = + { ARGUMENT_NUMBER, ARG_NUM_e, "ARGUMENT-NUMBER" }; + symbol_elem_t *e = symbol_special_add(PROGRAM, &special); + $$ = cbl_special_name_of(e); + } + | ENVIRONMENT_NAME { + // Add the name now, as a convenience. + cbl_special_name_t special = + { ENVIRONMENT_NAME, ENV_NAME_e, "ENVIRONMENT-NAME" }; + symbol_elem_t *e = symbol_special_add(PROGRAM, &special); + $$ = cbl_special_name_of(e); + } + | ENVIRONMENT_VALUE { + // Add the name now, as a convenience. + cbl_special_name_t special = + { ENVIRONMENT_VALUE, ENV_VALUE_e, "ENVIRONMENT-VALUE" }; + symbol_elem_t *e = symbol_special_add(PROGRAM, &special); + $$ = cbl_special_name_of(e); + } + ; + +exhibit_stmt: EXHIBIT exh_changed exh_named vargs { + statement_begin(@1, EXHIBIT); + std::vector<cbl_refer_t> args( $vargs->args.begin(), + $vargs->args.end() ); + parser_exhibit( $exh_changed, $exh_named, args ); + } + ; +exh_changed: %empty { $$ = false; } + | CHANGED { $$ = true; } + ; +exh_named: %empty { $$ = false; } + | NAMED { $$ = true; } ; divide: divide_impl end_divide { ast_divide($1); } @@ -5647,19 +5800,20 @@ end_program: end_program1[end] '.' gcc_unreachable(); } if( !matches ) { - error_msg(@end, "END %s %s' does not match IDENTIFICATION DIVISION '%s'", + error_msg($end.loc, "END %s %s does not match " + "%<IDENTIFICATION DIVISION %s%>", token_name, name, prog->name); YYERROR; } if( 0 != strcasecmp(prog->name, name) ) { - error_msg(@end, "END PROGRAM '%s' does not match PROGRAM-ID '%s'", + error_msg($end.loc, "END PROGRAM '%s' does not match PROGRAM-ID '%s'", name, prog->name); YYERROR; } std::set<std::string> externals = current.end_program(); if( !externals.empty() ) { - for( auto name : externals ) { + for( const auto& name : externals ) { yywarn("%s calls external symbol '%s'", prog->name, name.c_str()); } YYERROR; @@ -5678,28 +5832,32 @@ end_program: end_program1[end] '.' token_name = "FUNCTION"; break; default: - cbl_internal_error( "END token invalid"); + cbl_internal_error( "%<END%> token invalid"); } - error_msg(@end, "END %s requires NAME before '.'", token_name); + error_msg(@end, "%<END%> %s requires %<NAME%> before %<.%>", token_name); YYERROR; } ; end_program1: END_PROGRAM namestr[name] { + $$.loc = @name; $$.token = END_PROGRAM; $$.name = $name; } | END_FUNCTION namestr[name] { + $$.loc = @name; $$.token = END_FUNCTION; $$.name = $name; } | END_PROGRAM '.' // error { + $$.loc = @1; $$.token = END_PROGRAM; } | END_FUNCTION '.' // error { + $$.loc = @1; $$.token = END_FUNCTION; } ; @@ -5754,7 +5912,7 @@ exit_with: %empty static cbl_refer_t status(rt); $$ = &status; } - auto prog = cbl_label_of(symbol_at(current_program_index())); + const auto prog = cbl_label_of(symbol_at(current_program_index())); if( prog->returning ) { $$ = new cbl_refer_t( cbl_field_of(symbol_at(prog->returning)) ); } @@ -6338,17 +6496,17 @@ eval_abbrs: rel_term[a] { auto& ev( eval_stack.current() ); auto subj( ev.subject() ); if( !subj ) { - error_msg(@1, "WHEN %s phrase exceeds " + error_msg(@1, "WHEN %qs phrase exceeds " "subject set count of %zu", - $a.term->name(), ev.subject_count()); + nice_name_of($a.term->field), ev.subject_count()); YYERROR; } if( ! ev.compatible($a.term->field) ) { auto obj($a.term->field); error_msg(@1, "subject %s, type %s, " - "cannot be compared %s, type %s", - subj->name, 3 + cbl_field_type_str(subj->type), - obj->name, 3 + cbl_field_type_str(obj->type) ); + "cannot be compared %s, type %s", + subj->name, 3 + cbl_field_type_str(subj->type), + obj->name, 3 + cbl_field_type_str(obj->type) ); } auto result = ev.compare(*$a.term); if( ! result ) YYERROR; @@ -6443,7 +6601,7 @@ true_false: TRUE_kw { $$ = TRUE_kw; } scalar: tableref { // Check for missing subscript; others already checked. - if( $1->nsubscript == 0 && 0 < dimensions($1->field) ) { + if( $1->nsubscript() == 0 && 0 < dimensions($1->field) ) { subscript_dimension_error(@1, 0, $$); } } @@ -6454,8 +6612,8 @@ tableref: tableish { $$ = $1; $$->loc = @1; if( $$->is_table_reference() ) { - if( $$->nsubscript != dimensions($$->field) ) { - subscript_dimension_error(@1, $$->nsubscript, $$); + if( $$->nsubscript() != dimensions($$->field) ) { + subscript_dimension_error(@1, $$->nsubscript(), $$); YYERROR; } } @@ -6535,7 +6693,7 @@ name: qname auto name = names.front(); names.pop_front(); auto e = symbol_field_forward_add(PROGRAM, parent, - name, yylineno); + name, @1.first_line); if( !e ) YYERROR; symbol_field_location( symbol_index(e), @qname ); parent = symbol_index(e); @@ -6565,6 +6723,10 @@ ctx_name: NAME context_word: APPLY { static char s[] ="APPLY"; $$ = s; } // screen description entry + | ARGUMENT_NUMBER { static char s[] ="ARGUMENT-NUMBER"; + $$ = s; } // Display Upon / Accept From + | ARGUMENT_VALUE { static char s[] ="ARGUMENT-VALUE"; + $$ = s; } // Accept From | ARITHMETIC { static char s[] ="ARITHMETIC"; $$ = s; } // OPTIONS paragraph | ATTRIBUTE { static char s[] ="ATTRIBUTE"; @@ -6601,6 +6763,10 @@ context_word: APPLY { static char s[] ="APPLY"; $$ = s; } // ERASE clause in a screen description entry | ENTRY_CONVENTION { static char s[] ="ENTRY-CONVENTION"; $$ = s; } // OPTIONS paragraph + | ENVIRONMENT_NAME { static char s[] ="ENVIRONMENT-NAME"; + $$ = s; } // Display Upon + | ENVIRONMENT_VALUE { static char s[] ="ENVIRONMENT-VALUE"; + $$ = s; } // Display Upon / Accept From | ERASE { static char s[] ="ERASE"; $$ = s; } // screen description entry | EXPANDS { static char s[] ="EXPANDS"; @@ -6731,7 +6897,7 @@ move: MOVE scalar TO move_tgts[tgts] { statement_begin(@1, MOVE); if( $scalar->field->type == FldIndex ) { - error_msg(@1, "'%s' cannot be MOVEd because it's an INDEX", + error_msg(@1, "%qs cannot be MOVEd because it is an %<INDEX%>", name_of($scalar->field) ); YYERROR; } @@ -6949,9 +7115,9 @@ arith_err: SIZE_ERROR *ptgt = $1 == NOT? current.compute_not_error() : current.compute_on_error(); } else { - *ptgt = label_add(LblArith, uniq_label("arith"), yylineno); + *ptgt = label_add(LblArith, uniq_label("arith"), @1.first_line); } - (*ptgt)->lain = yylineno; + (*ptgt)->lain = @1.first_line; parser_arith_error( *ptgt ); } ; @@ -7004,6 +7170,15 @@ num_value: scalar // might actually be a string | num_literal { $$ = new_reference($1); } | ADDRESS OF scalar {$$ = $scalar; $$->addr_of = true; } | DETAIL OF scalar {$$ = $scalar; } + | LENGTH_OF binary_type[size] { + location_set(@1); + $$ = new cbl_refer_t( new_tempnumeric() ); + $$->field->clear_attr(signable_e); + if( dialect_gcc() ) { + dialect_error(@1, "LENGTH OF", "ibm"); + } + parser_set_numeric($$->field, $size); + } | LENGTH_OF name[val] { location_set(@1); $$ = new cbl_refer_t( new_tempnumeric() ); @@ -7114,9 +7289,21 @@ section_kw: SECTION { if( $1 ) { if( *$1 == '-' ) { - error_msg(@1, "SECTION segment %s is negative", $1); + error_msg(@1, "SECTION segment %qs is negative", $1); } else { - cbl_unimplementedw("SECTION segment %s was ignored", $1); + if( dialect_ibm() ) { + int sectno; + sscanf($1, "%d", §no); + if( ! (0 <= sectno && sectno <= 99) ) { + error_msg(@1, "SECTION segment %qs must be 0-99", $1); + } else { + if(false) { // stand-in for warning, someday. + yywarn("SECTION segment %qs was ignored", $1); + } + } + } else { + cbl_unimplemented("SECTION segment %qs is not ISO syntax", $1); + } } } } @@ -7218,6 +7405,15 @@ signed_literal: num_literal struct cbl_field_t *zero = constant_of(constant_index(ZERO)); parser_subtract( $$, zero, $2, current_rounded_mode() ); } + | LENGTH_OF binary_type[size] { + location_set(@1); + $$ = new_tempnumeric(); + $$->clear_attr(signable_e); + if( dialect_gcc() ) { + dialect_error(@1, "LENGTH OF", "ibm"); + } + parser_set_numeric($$, $size); + } | LENGTH_OF name[val] { location_set(@1); $$ = new_tempnumeric(); @@ -7458,6 +7654,7 @@ perform_cond: UNTIL { parser_perform_conditional( &perform_current()->tgt); } perform_inline: perform_start statements END_PERFORM { location_set(@END_PERFORM); + parser_sleep(*cbl_refer_t::empty()); $$ = perform_current(); if( $perform_start == LOCATION ) { error_msg(@1, "LOCATION not valid with PERFORM Format 2"); @@ -7466,12 +7663,14 @@ perform_inline: perform_start statements END_PERFORM | perform_start END_PERFORM { location_set(@END_PERFORM); + parser_sleep(*cbl_refer_t::empty()); $$ = perform_current(); if( $perform_start == LOCATION ) { error_msg(@1, "LOCATION not valid with PERFORM Format 2"); } } ; + perform_start: %empty %prec LOCATION { perform_ec_setup(); $$ = 0; @@ -7498,18 +7697,7 @@ perform_except: perform_start perform_ec_finally END_PERFORM { - auto perf = perform_current(); - // produce blob, jumped over by FINALLY paragraph - size_t iblob = symbol_declaratives_add( PROGRAM, perf->dcls ); - auto lave = perf->ec_labels.new_label(LblParagraph, "lave"); - auto handlers = cbl_field_of(symbol_at(iblob)); - - // install blob - parser_label_label(perf->ec_labels.init); - declarative_runtime_match(handlers, lave); - - // uninstall blob - parser_label_label(perf->ec_labels.fini); + cbl_unimplemented("PERFORM Format 3"); } ; @@ -7527,7 +7715,7 @@ perform_when1: WHEN perform_ec { std::transform( $perform_ec->elems.begin(), $perform_ec->elems.end(), std::back_inserter(perf->dcls), - []( cbl_declarative_t *p ) { + []( const cbl_declarative_t *p ) { return *p; } ); ast_enter_paragraph(when); @@ -7617,12 +7805,12 @@ except_files: except_name[ec] FILE_KW filenames { perform_ec_other: %empty %prec WHEN { - auto& ec_labels( perform_current()->ec_labels ); + const auto& ec_labels( perform_current()->ec_labels ); ast_enter_paragraph(ec_labels.other); parser_exit_paragraph(); } | WHEN OTHER { - auto& ec_labels( perform_current()->ec_labels ); + const auto& ec_labels( perform_current()->ec_labels ); ast_enter_paragraph(ec_labels.other); } exception statements %prec WHEN { @@ -7631,12 +7819,12 @@ perform_ec_other: ; perform_ec_common: %empty { - auto& ec_labels( perform_current()->ec_labels ); + const auto& ec_labels( perform_current()->ec_labels ); ast_enter_paragraph(ec_labels.common); parser_exit_paragraph(); } | WHEN COMMON { - auto& ec_labels( perform_current()->ec_labels ); + const auto& ec_labels( perform_current()->ec_labels ); ast_enter_paragraph(ec_labels.common); } exception statements { @@ -7645,18 +7833,18 @@ perform_ec_common: ; perform_ec_finally: %empty { - auto& ec_labels( perform_current()->ec_labels ); + const auto& ec_labels( perform_current()->ec_labels ); ast_enter_paragraph(ec_labels.finally); parser_exit_paragraph(); parser_label_goto(ec_labels.fini); } | FINALLY { - auto& ec_labels( perform_current()->ec_labels ); + const auto& ec_labels( perform_current()->ec_labels ); ast_enter_paragraph(ec_labels.finally); } exception statements { parser_exit_paragraph(); - auto& ec_labels( perform_current()->ec_labels ); + const auto& ec_labels( perform_current()->ec_labels ); parser_label_goto(ec_labels.fini); } ; @@ -7787,6 +7975,15 @@ varg1a: ADDRESS OF scalar { { $$ = new_reference(constant_of(constant_index($1))); } + | LENGTH_OF binary_type[size] { + location_set(@1); + $$ = new cbl_refer_t( new_tempnumeric() ); + $$->field->clear_attr(signable_e); + if( dialect_gcc() ) { + dialect_error(@1, "LENGTH OF", "ibm"); + } + parser_set_numeric($$->field, $size); + } | LENGTH_OF name[val] { location_set(@1); $$ = new cbl_refer_t( new_tempnumeric() ); @@ -7811,6 +8008,10 @@ varg1a: ADDRESS OF scalar { } ; +binary_type: BINARY_INTEGER { $$ = $1.capacity; } + | COMPUTATIONAL { $$ = $1.capacity; } + ; + literal: literalism { $$ = $1.isymbol()? @@ -7854,7 +8055,7 @@ raise: RAISE EXCEPTION NAME "EXCEPTION CONDITION: %s", $NAME); YYERROR; } - cbl_unimplemented("RAISE <EXCEPTION OBJECT>"); + cbl_unimplemented("RAISE %<EXCEPTION OBJECT%>"); YYERROR; } ; @@ -7921,10 +8122,6 @@ read_body: NAME read_next read_into read_key error_msg(@1, "syntax error? invalid file record name"); YYERROR; } - if( 0 && $$->access == file_access_dyn_e && $read_next >= 0 ) { - error_msg(@1, "sequential DYNAMIC access requires NEXT RECORD"); - YYERROR; - } if( $read_key->field && is_sequential($$) ) { error_msg(@1, "SEQUENTIAL file %s has no KEY", $$->name); YYERROR; @@ -7935,7 +8132,7 @@ read_body: NAME read_next read_into read_key YYERROR; } if( $read_key->field && $read_next < 0 ) { - error_msg(@1, "cannot read NEXT with KEY", $$->name); + error_msg(@1, "cannot read NEXT with KEY %qs", $$->name); YYERROR; } @@ -8372,8 +8569,8 @@ merge: MERGE { statement_begin(@1, MERGE); } USING filenames[inputs] sort_output { std::vector <cbl_key_t> keys($sort_keys->key_list.size()); - std::copy( $sort_keys->key_list.begin(), - $sort_keys->key_list.end(), keys.begin() ); + std::copy( $sort_keys->key_list.begin(), + $sort_keys->key_list.end(), keys.begin() ); size_t ninput = $inputs->files.size(); size_t noutput = $sort_output->nfile(); @@ -8392,8 +8589,7 @@ merge: MERGE { statement_begin(@1, MERGE); } out_proc = &$sort_output->tgt; } - parser_file_merge( $file, $sort_seq, - keys.size(), keys.empty()? NULL : keys.data(), + parser_file_merge( $file, $sort_seq, keys, ninput, inputs, noutput, outputs, out_proc ); @@ -8559,7 +8755,7 @@ set: SET set_tgts[tgts] TO set_operand[src] class set_conditional { bool tf; public: - set_conditional( int token ) : tf(token == TRUE_kw) {} + explicit set_conditional( int token ) : tf(token == TRUE_kw) {} void operator()(cbl_refer_t& refer) { if( refer.field->data.false_value_of() == NULL && !tf ) { auto loc = symbol_field_location(field_index(refer.field)); @@ -8584,7 +8780,7 @@ set_switches: switches TO on_off { struct switcheroo { bitop_t op; - switcheroo( bool tf ) : op( tf? bit_set_op : bit_clear_op ) {} + explicit switcheroo( bool tf ) : op( tf? bit_set_op : bit_clear_op ) {} switcheroo& operator()(cbl_field_t* sw) { assert(sw->type == FldSwitch); assert(sw->data.initial); // not a switch condition @@ -8639,12 +8835,12 @@ search_1_body: name[table] search_varying[varying] cbl_name_t label_name; auto len = snprintf(label_name, sizeof(label_name), - "linear_search_%d", yylineno); + "linear_search_%d", @1.first_line); if( ! (0 < len && len < int(sizeof(label_name))) ) { gcc_unreachable(); } cbl_label_t *name = label_add( LblSearch, - label_name, yylineno ); + label_name, @1.first_line ); auto varying($varying); if( index == varying ) varying = NULL; parser_lsearch_start( name, $table, index, varying ); @@ -8697,9 +8893,9 @@ search_binary: SEARCH ALL search_2_body search_2_cases search_2_body: name[table] { statement_begin(@$, SEARCH); - char *label_name = xasprintf("binary_search_%d", yylineno); + char *label_name = xasprintf("binary_search_%d", @1.first_line); cbl_label_t *name = label_add( LblSearch, - label_name, yylineno ); + label_name, @1.first_line ); parser_bsearch_start( name, $table ); search_alloc(name); } @@ -8724,14 +8920,14 @@ search_terms: search_term ; search_term: scalar[key] '=' search_expr[sarg] { - if( $key->nsubscript == 0 ) { + if( $key->nsubscript() == 0 ) { error_msg(@1, "no index for key"); YYERROR; } - if( dimensions($key->field) < $key->nsubscript ) { + if( dimensions($key->field) < $key->nsubscript() ) { error_msg(@1, "too many subscripts: " - "%zu for table of %zu dimensions", - $key->nsubscript, dimensions($key->field) ); + "%u for table of %zu dimensions", + $key->nsubscript(), dimensions($key->field) ); YYERROR; } @@ -8770,8 +8966,7 @@ sort_table: SORT tableref[table] sort_keys sort_dup sort_seq { keys.at(i++) = cbl_key_t(k); } - parser_sort( *$table, $sort_dup, $sort_seq, - keys.size(), keys.empty()? NULL : keys.data() ); + parser_sort( *$table, $sort_dup, $sort_seq, keys ); } | SORT tableref[table] sort_dup sort_seq { statement_begin(@1, SORT); @@ -8781,9 +8976,10 @@ sort_table: SORT tableref[table] sort_keys sort_dup sort_seq { cbl_key_t key = cbl_key_t($table->field->occurs.keys[0]), guess(1, &$table->field); - ; - if( key.nfield == 0 ) key = guess; - parser_sort( *$table, $sort_dup, $sort_seq, 1, &key ); + + if( key.fields.empty() ) key = guess; + std::vector<cbl_key_t> keys(1, key); + parser_sort( *$table, $sort_dup, $sort_seq, keys ); } ; @@ -8824,7 +9020,7 @@ sort_file: SORT FILENAME[file] sort_keys sort_dup sort_seq parser_file_sort( file, $sort_dup, $sort_seq, - keys.size(), keys.empty()? NULL : keys.data(), + keys, ninput, inputs, noutput, outputs, in_proc, out_proc ); @@ -9016,7 +9212,7 @@ backward: %empty { $$ = false; } inspect: INSPECT backward inspected TALLYING tallies { statement_begin(@1, INSPECT); - ast_inspect( *$inspected, $backward, *$tallies ); + ast_inspect( @$, *$inspected, $backward, *$tallies ); } | INSPECT backward inspected TALLYING tallies REPLACING replacements { @@ -9028,8 +9224,8 @@ inspect: INSPECT backward inspected TALLYING tallies } statement_begin(@1, INSPECT); // All tallying is done before any replacing - ast_inspect( *$inspected, $backward, *$tallies ); - ast_inspect( *$inspected, $backward, *$replacements ); + ast_inspect( @$, *$inspected, $backward, *$tallies ); + ast_inspect( @$, *$inspected, $backward, *$replacements ); } | INSPECT backward inspected REPLACING replacements { @@ -9040,11 +9236,11 @@ inspect: INSPECT backward inspected TALLYING tallies YYERROR; } statement_begin(@1, INSPECT); - ast_inspect( *$inspected, $backward, *$replacements ); + ast_inspect( @$, *$inspected, $backward, *$replacements ); } | INSPECT backward inspected CONVERTING alpha_val[match] TO all alpha_val[replace_oper] - insp_mtquals[qual] + insp_mtqual[qual] { if( $all ) { $replace_oper->all = true; @@ -9064,7 +9260,7 @@ inspect: INSPECT backward inspected TALLYING tallies if( is_literal(match) && is_literal(replace) ) { if( !$match->all && !$replace_oper->all) { if( match->data.capacity != replace->data.capacity ) { - error_msg(@match, "'%s', size %u NOT EQUAL '%s', size %u", + error_msg(@match, "%qs, size %u NOT EQUAL %qs, size %u", nice_name_of(match), match->data.capacity, nice_name_of(replace), replace->data.capacity); YYERROR; @@ -9090,7 +9286,7 @@ inspect: INSPECT backward inspected TALLYING tallies tallies: { need_nume_set(); } tally { - $$ = new ast_inspect_list_t( *$tally ); + $$ = new cbl_inspect_opers_t( 1, *$tally ); } | tallies { need_nume_set(); } tally { @@ -9100,12 +9296,17 @@ tallies: { need_nume_set(); } tally if( !next.tally.field ) { // prior tally swallowed one too many cbl_inspect_t& prior = $$->back(); - assert(prior.nbound > 0); - assert(prior.opers); - cbl_inspect_oper_t& prior_op = prior.opers[prior.nbound - 1]; - - assert(prior_op.n_identifier_3 > 0 ); - next.tally = prior_op.matches[--prior_op.n_identifier_3].matching; + assert(prior.nbound() > 0); + cbl_inspect_oper_t& prior_op = prior.back(); + assert(! prior_op.matches.empty() ); + assert(prior_op.n_identifier_3() > 0 ); + cbl_inspect_match_t wrong_match = prior_op.matches.back(); + dbgmsg("moving overeager tally to next clause"); + dump_inspect_match(wrong_match); + next.tally = wrong_match.premature_tally(); + if( wrong_match.empty() ) { + prior_op.matches.pop_back(); + } } if( !next.tally.field ) { error_msg(@$, "missing summation field before FOR"); @@ -9117,44 +9318,37 @@ tallies: { need_nume_set(); } tally /* * numref might be "empty" only because it was consumed by a - * prior insp_mtquals, which can end in a scalar. If that + * prior insp_mtqual, which can end in a scalar. If that * happens, the tallies target, above, takes back the borrowed * scalar and assigns it to be the tally total, as the user * intended. */ tally: numeref[total] FOR tally_fors[fors] - { // reduce ast_inspect_t to cbl_inspect_t + { if( yydebug && !$total ) { - error_msg(@FOR, "caution: missing summation field before FOR"); + dbgmsg("tally: caution: missing summation field before FOR"); } - cbl_refer_t total( $total? *$total : cbl_refer_t() ); - $$ = new cbl_inspect_t( total, $fors->opers() ); + $$ = $fors; + if( $total ) $$->tally = *$total; } ; -tally_fors: tally_forth - { // reduce ast_inspect_oper_t to cbl_inspect_oper_t - cbl_inspect_oper_t oper( $1->bound, $1->matches ); - $$ = new ast_inspect_t; - $$ ->push_back(oper); - } - | tally_fors tally_forth - { - cbl_inspect_oper_t oper( $2->bound, $2->matches ); - $1 ->push_back(oper); - } +tally_fors: tally_forth { $$ = new cbl_inspect_t(1, *$1); } + | tally_fors tally_forth { $$->push_back(*$2); $$ = $1; } ; -tally_forth: CHARACTERS insp_mtquals[q] scalar[next_tally] +tally_forth: CHARACTERS insp_mtqual[q] scalar[next_tally] { // Add ensuing scalar as if it were an argument to CHARACTERS. // It will be moved to the succeeding FOR as its tally. - $q->matching = *$next_tally; - $$ = new ast_inspect_oper_t(*$q); + dbgmsg("saving overeager tally for next clause"); + $q->save_premature_tally(*$next_tally); + $$ = new cbl_inspect_oper_t(*$q); + dump_inspect_match($$->matches.back()); } - | CHARACTERS insp_mtquals[q] + | CHARACTERS insp_mtqual[q] { - $$ = new ast_inspect_oper_t(*$q); + $$ = new cbl_inspect_oper_t(*$q); } | ALL tally_matches[q] { $q->bound = bound_all_e; @@ -9173,26 +9367,23 @@ tally_forth: CHARACTERS insp_mtquals[q] scalar[next_tally] } ; -tally_matches: tally_match { $$ = new ast_inspect_oper_t(*$1); } +tally_matches: tally_match { $$ = new cbl_inspect_oper_t(*$1); } | tally_matches tally_match { // add to the list of matches for an operand $1->matches.push_back(*$2); } ; -tally_match: alpha_val[matching] insp_mtquals[q] +tally_match: alpha_val[matching] insp_mtqual[q] { // include the matching field with the qualifiers $$ = $q; - $$->matching = *$matching; + $$->matching(*$matching); } ; numeref: %empty { $$ = NULL; need_nume_set(false); } | nume[name] subscripts[subs] { - size_t n = $subs->size(); - auto offsets = new cbl_refer_t[n]; - std::copy( $subs->begin(), $subs->end(), offsets ); - $$ = new cbl_refer_t($name, n, offsets); + $$ = new cbl_refer_t($name, $subs->vectorize()); } | nume { $$ = new cbl_refer_t($nume); } ; @@ -9222,13 +9413,13 @@ qnume: NUME { name_queue.qualify(@1, $1); } replacements: replacement { - cbl_inspect_t inspect( cbl_refer_t(), $1->opers() ); - $$ = new ast_inspect_list_t(inspect); + cbl_inspect_t inspect( cbl_refer_t(), *$1 ); + $$ = new cbl_inspect_opers_t(1, inspect); } ; replacement: replace_oper { - $$ = new ast_inspect_t; + $$ = new cbl_inspect_t; $$->push_back( cbl_inspect_oper_t($1->bound, $1->replaces) ); } | replacement replace_oper @@ -9236,9 +9427,9 @@ replacement: replace_oper $$->push_back( cbl_inspect_oper_t($2->bound, $2->replaces) ); } ; -replace_oper: CHARACTERS BY alpha_val[replace] insp_mtquals[q] +replace_oper: CHARACTERS BY alpha_val[replace] insp_mtqual[q] { - $$ = new ast_inspect_oper_t( cbl_inspect_replace_t(NULL, + $$ = new cbl_inspect_oper_t( cbl_inspect_replace_t(NULL, *$replace, $q->before, $q->after) ); @@ -9252,21 +9443,22 @@ replace_oper: CHARACTERS BY alpha_val[replace] insp_mtquals[q] x_by_ys: x_by_y { - $$ = new ast_inspect_oper_t(*$1); + $$ = new cbl_inspect_oper_t(*$1); } | x_by_ys x_by_y { $$->replaces.push_back(*$2); } ; -x_by_y: alpha_val[matching] BY alpha_val[replace] insp_mtquals[q] +x_by_y: alpha_val[matching] BY alpha_val[replace] insp_mtqual[q] { $$ = new cbl_inspect_replace_t(*$matching, *$replace, $q->before, $q->after); } ; -insp_mtquals: %empty { $$ = new cbl_inspect_match_t; } + /* mt may be "empty": match may have no qualifiers */ +insp_mtqual: %empty { $$ = new cbl_inspect_match_t; } | insp_quals ; insp_quals: insp_qual { @@ -9276,6 +9468,7 @@ insp_quals: insp_qual { } else { $$->after = *$insp_qual.qual; } + dump_inspect_match(*$$); } | insp_quals insp_qual { @@ -9647,7 +9840,7 @@ call_except: EXCEPTION { $$.not_error = NULL; $$.on_error = label_add(LblArith, - uniq_label("call"), yylineno); + uniq_label("call"), @1.first_line); if( !$$.on_error ) YYERROR; parser_call_exception( $$.on_error ); @@ -9660,7 +9853,7 @@ call_except: EXCEPTION { $$.not_error = NULL; $$.on_error = label_add(LblArith, - uniq_label("call"), yylineno); + uniq_label("call"), @1.first_line); if( !$$.on_error ) YYERROR; parser_call_exception( $$.on_error ); @@ -9695,7 +9888,7 @@ alter_tgt: label_1[old] alter_to label_1[new] cbl_perform_tgt_t tgt( $old, $new ); parser_alter(&tgt); - auto prog = cbl_label_of( symbol_at(symbol_elem_of($old)->program)); + const auto prog = cbl_label_of( symbol_at(symbol_elem_of($old)->program)); if( prog->initial ) { cbl_unimplemented("ALTER %s", $old->name); } @@ -9716,7 +9909,7 @@ go_to: GOTO labels[args] } for( auto& label : $args->elems ) { - label->used = yylineno; + label->used = @2.first_line; } cbl_label_t *arg = $args->elems.front(); parser_goto( cbl_refer_t(), 1, &arg ); @@ -9728,7 +9921,7 @@ go_to: GOTO labels[args] std::vector <cbl_label_t *> args($args->elems.size()); std::copy($args->elems.begin(), $args->elems.end(), args.begin()); for( auto& label : $args->elems ) { - label->used = yylineno; + label->used = @2.first_line; } parser_goto( *$value, args.size(), args.data() ); } @@ -9748,7 +9941,7 @@ resume: RESUME NEXT STATEMENT { statement_begin(@1, RESUME); parser_clear_exception(); - $tgt->used = yylineno; + $tgt->used = @1.first_line; parser_goto( cbl_refer_t(), 1, &$tgt ); } ; @@ -9923,7 +10116,7 @@ on_overflow: OVERFLOW_kw { $$.not_error = NULL; $$.on_error = label_add(LblString, - uniq_label("string"), yylineno); + uniq_label("string"), @1.first_line); if( !$$.on_error ) YYERROR; parser_string_overflow( $$.on_error ); @@ -10086,12 +10279,14 @@ function_udf: FUNCTION_UDF '(' arg_list[args] ')' { if( ! current.udf_args_valid(L, $args->refers, params) ) { YYERROR; } - $$ = new_temporary_clone(cbl_field_of(symbol_at(L->returning))); + const auto returning = cbl_field_of(symbol_at(L->returning)); + $$ = new_temporary_clone(returning); + $$->data.initial = returning->name; // user's name for the field std::vector <cbl_ffi_arg_t> args($args->refers.size()); size_t i = 0; // Pass parameters as defined by the function. std::transform( $args->refers.begin(), $args->refers.end(), args.begin(), - [params, &i]( cbl_refer_t& arg ) { + [params, &i]( const cbl_refer_t& arg ) { function_descr_arg_t param = params.at(i++); auto ar = new cbl_refer_t(arg); cbl_ffi_arg_t actual(param.crv, ar); @@ -10105,7 +10300,9 @@ function_udf: FUNCTION_UDF '(' arg_list[args] ')' { static cbl_ffi_arg_t *args = NULL; auto L = cbl_label_of(symbol_at($1)); - $$ = new_temporary_clone(cbl_field_of(symbol_at(L->returning))); + const auto returning = cbl_field_of(symbol_at(L->returning)); + $$ = new_temporary_clone(returning); + $$->data.initial = returning->name; // user's name for the field auto name = new_literal(strlen(L->name), L->name, quoted_e); ast_call( @1, name, $$, narg, args, NULL, NULL, true ); @@ -10138,15 +10335,15 @@ intrinsic: function_udf args.data()); if( p != NULL ) { auto loc = symbol_field_location(field_index(p->field)); - error_msg(loc, "FUNCTION %s has " - "inconsistent parameter type %zu ('%s')", + error_msg(loc, "FUNCTION %qs has " + "inconsistent parameter type %td (%qs)", keyword_str($1), p - args.data(), name_of(p->field) ); YYERROR; } $$ = is_numeric(args[0].field)? new_tempnumeric_float() : new_alphanumeric(); - + $$->data.initial = keyword_str($1); parser_intrinsic_callv( $$, intrinsic_cname($1), args.size(), args.data() ); } @@ -10155,7 +10352,7 @@ intrinsic: function_udf { static char s[] = "__gg__present_value"; location_set(@1); - $$ = new_tempnumeric_float(); + $$ = new_tempnumeric_float("PRESENT-VALUE"); size_t n = $args->size(); assert(n > 0); if( n < 2 ) { @@ -10173,56 +10370,56 @@ intrinsic: function_udf | BASECONVERT '(' varg[r1] varg[r2] varg[r3] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("BASECONVERT"); cbl_unimplemented("BASECONVERT"); if( ! intrinsic_call_3($$, BASECONVERT, $r1, $r2, $r3 )) YYERROR; } | BIT_OF '(' expr[r1] ')' { location_set(@1); - $$ = new_alphanumeric(); + $$ = new_alphanumeric("BIT-OF"); if( ! intrinsic_call_1($$, BIT_OF, $r1, @r1)) YYERROR; } | CHAR '(' expr[r1] ')' { location_set(@1); - $$ = new_alphanumeric(1); + $$ = new_alphanumeric(1,"CHAR"); if( ! intrinsic_call_1($$, CHAR, $r1, @r1)) YYERROR; } | CONVERT '(' varg[r1] convert_src[src] convert_dst[dst] ')' { location_set(@1); - $$ = new_alphanumeric(1); + $$ = new_alphanumeric(1,"CONVERT"); cbl_unimplemented("CONVERT"); /* if( ! intrinsic_call_3($$, CONVERT, $r1, $src, $dst) ) YYERROR; */ } | DISPLAY_OF '(' varg[r1] ')' { location_set(@1); - $$ = new_alphanumeric(); + $$ = new_alphanumeric("DISPLAY-OF"); if( ! intrinsic_call_2($$, DISPLAY_OF, $r1, NULL) ) YYERROR; } | DISPLAY_OF '(' varg[r1] varg[r2] ')' { location_set(@1); - $$ = new_alphanumeric(); + $$ = new_alphanumeric("DISPLAY-OF"); if( ! intrinsic_call_2($$, DISPLAY_OF, $r1, $r2) ) YYERROR; } | EXCEPTION_FILE filename { location_set(@1); - $$ = new_alphanumeric(); + $$ = new_alphanumeric("EXCEPTION-FILE"); parser_exception_file( $$, $filename ); } | FIND_STRING '(' varg[r1] last start_after anycase ')' { location_set(@1); - $$ = new_alphanumeric(); + $$ = new_alphanumeric("FIND-STRING"); /* auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); */ - cbl_unimplemented("FIND_STRING"); + cbl_unimplemented("%<FIND_STRING%>"); /* if( ! intrinsic_call_4($$, FIND_STRING, r1, $r2) ) YYERROR; */ } | FORMATTED_DATE '(' DATE_FMT[r1] expr[r2] ')' { location_set(@1); - $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATE); + $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATE, "FORMATTED-DATE"); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); if( ! intrinsic_call_2($$, FORMATTED_DATE, r1, $r2) ) YYERROR; } @@ -10231,7 +10428,7 @@ intrinsic: function_udf | FORMATTED_DATETIME '(' DATETIME_FMT[r1] expr[r2] expr[r3] ')' { location_set(@1); - $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME); + $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME, "FORMATTED-DATETIME"); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); static cbl_refer_t r3(literally_zero); if( ! intrinsic_call_4($$, FORMATTED_DATETIME, @@ -10240,7 +10437,7 @@ intrinsic: function_udf | FORMATTED_DATETIME '(' DATETIME_FMT[r1] expr[r2] expr[r3] expr[r4] ')' { location_set(@1); - $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME); + $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME, "FORMATTED-DATETIME"); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); if( ! intrinsic_call_4($$, FORMATTED_DATETIME, r1, $r2, $r3, $r4) ) YYERROR; @@ -10251,14 +10448,14 @@ intrinsic: function_udf | FORMATTED_TIME '(' TIME_FMT[r1] expr[r2] expr[r3] ')' { location_set(@1); - $$ = new_alphanumeric(MAXLENGTH_FORMATTED_TIME); + $$ = new_alphanumeric(MAXLENGTH_FORMATTED_TIME, "FORMATTED-DATETIME"); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); if( ! intrinsic_call_3($$, FORMATTED_TIME, r1, $r2, $r3) ) YYERROR; } | FORMATTED_TIME '(' TIME_FMT[r1] expr[r2] ')' { location_set(@1); - $$ = new_alphanumeric(MAXLENGTH_FORMATTED_TIME); + $$ = new_alphanumeric(MAXLENGTH_FORMATTED_TIME, "FORMATTED-TIME"); auto r3 = new_reference(new_literal("0")); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); if( ! intrinsic_call_3($$, FORMATTED_TIME, @@ -10266,21 +10463,21 @@ intrinsic: function_udf } | FORMATTED_CURRENT_DATE '(' DATETIME_FMT[r1] ')' { location_set(@1); - $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME); + $$ = new_alphanumeric(MAXLENGTH_FORMATTED_DATETIME, "FORMATTED-CURRENT_DATE"); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); if( ! intrinsic_call_1($$, FORMATTED_CURRENT_DATE, r1, @r1) ) YYERROR; } | TEST_FORMATTED_DATETIME '(' DATE_FMT[r1] varg[r2] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("TEST-FORMATTED-DATETIME"); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); if( ! intrinsic_call_2($$, TEST_FORMATTED_DATETIME, r1, $r2) ) YYERROR; } | TEST_FORMATTED_DATETIME '(' TIME_FMT[r1] varg[r2] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("TEST-FORMATTED-DATETIME"); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); if( ! intrinsic_call_2($$, TEST_FORMATTED_DATETIME, r1, $r2) ) YYERROR; @@ -10288,14 +10485,14 @@ intrinsic: function_udf | TEST_FORMATTED_DATETIME '(' DATETIME_FMT[r1] varg[r2] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("TEST-FORMATTED-DATETIME"); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); if( ! intrinsic_call_2($$, TEST_FORMATTED_DATETIME, r1, $r2) ) YYERROR; } | INTEGER_OF_FORMATTED_DATE '(' DATE_FMT[r1] varg[r2] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("INTEGER-OF-FORMATTED-DATE"); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); if( ! intrinsic_call_2($$, INTEGER_OF_FORMATTED_DATE, r1, $r2) ) YYERROR; @@ -10303,14 +10500,14 @@ intrinsic: function_udf | INTEGER_OF_FORMATTED_DATE '(' DATETIME_FMT[r1] varg[r2] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("INTEGER-OF-FORMATTED-DATE"); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); if( ! intrinsic_call_2($$, INTEGER_OF_FORMATTED_DATE, r1, $r2) ) YYERROR; } | SECONDS_FROM_FORMATTED_TIME '(' TIME_FMT[r1] varg[r2] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("SECONDS-FROM-FORMATTED-TIME"); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); if( ! intrinsic_call_2($$, SECONDS_FROM_FORMATTED_TIME, r1, $r2) ) YYERROR; @@ -10318,7 +10515,7 @@ intrinsic: function_udf | SECONDS_FROM_FORMATTED_TIME '(' DATETIME_FMT[r1] varg[r2] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("SECONDS-FROM-FORMATTED-TIME"); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); if( ! intrinsic_call_2($$, SECONDS_FROM_FORMATTED_TIME, r1, $r2) ) YYERROR; @@ -10326,85 +10523,85 @@ intrinsic: function_udf | HEX_OF '(' varg[r1] ')' { location_set(@1); - $$ = new_alphanumeric(); + $$ = new_alphanumeric("HEX-OF"); if( ! intrinsic_call_1($$, HEX_OF, $r1, @r1)) YYERROR; } | LENGTH '(' tableish[val] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("LENGTH"); $$->clear_attr(signable_e); parser_set_numeric($$, $val->field->size()); if( ! intrinsic_call_1($$, LENGTH, $val, @val)) YYERROR; } | LENGTH '(' varg1a[val] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("LENGTH"); $$->clear_attr(signable_e); parser_set_numeric($$, $val->field->data.capacity); if( ! intrinsic_call_1($$, LENGTH, $val, @val)) YYERROR; } | lopper_case[func] '(' alpha_val[r1] ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric($r1->field->data.capacity, "lopper_case[func]"); if( ! intrinsic_call_1($$, $func, $r1, @r1)) YYERROR; } | MODULE_NAME '(' module_type[type] ')' { - $$ = new_alphanumeric(sizeof(cbl_name_t)); + $$ = new_alphanumeric(sizeof(cbl_name_t), "MODULE-NAME"); parser_module_name( $$, $type ); } | NUMVAL_C '(' varg[r1] numval_locale[r2] anycase ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("NUMVAL-C"); parser_intrinsic_numval_c( $$, *$r1, $r2.is_locale, *$r2.arg2, $anycase ); } | ORD '(' alpha_val[r1] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("ORD"); if( ! intrinsic_call_1($$, ORD, $r1, @r1)) YYERROR; } | RANDOM { location_set(@1); - $$ = new_tempnumeric_float(); + $$ = new_tempnumeric_float("RANDOM"); parser_intrinsic_call_0( $$, intrinsic_cname(RANDOM) ); } | RANDOM_SEED expr[r1] ')' { // left parenthesis consumed by lexer location_set(@1); - $$ = new_tempnumeric_float(); + $$ = new_tempnumeric_float("RANDOM-SEED"); if( ! intrinsic_call_1($$, RANDOM, $r1, @r1)) YYERROR; } | STANDARD_COMPARE '(' varg[r1] varg[r2] varg[r3] varg[r4] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("STANDARD-COMPARE"); cbl_unimplemented("STANDARD-COMPARE"); /* if( ! intrinsic_call_4($$, STANDARD_COMPARE, $r1) ) YYERROR; */ } | STANDARD_COMPARE '(' varg[r1] varg[r2] varg[r3] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("STANDARD-COMPARE"); cbl_unimplemented("STANDARD-COMPARE"); /* if( ! intrinsic_call_4($$, STANDARD_COMPARE, $r1) ) YYERROR; */ } | STANDARD_COMPARE '(' varg[r1] varg[r2] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("STANDARD-COMPARE"); cbl_unimplemented("STANDARD-COMPARE"); /* if( ! intrinsic_call_4($$, STANDARD_COMPARE, $r1) ) YYERROR; */ } | SUBSTITUTE '(' varg[r1] subst_inputs[inputs] ')' { location_set(@1); - $$ = new_alphanumeric(); + $$ = new_alphanumeric("SUBSTITUTE"); std::vector <cbl_substitute_t> args($inputs->size()); std::transform( $inputs->begin(), $inputs->end(), args.begin(), []( const substitution_t& arg ) { @@ -10420,7 +10617,7 @@ intrinsic: function_udf | TEST_NUMVAL_C '(' varg[r1] numval_locale[r2] anycase ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("parser_intrinsic_subst($$,"); parser_intrinsic_numval_c( $$, *$r1, $r2.is_locale, *$r2.arg2, $anycase, true ); } @@ -10447,14 +10644,14 @@ intrinsic: function_udf YYERROR; break; } - $$ = new_alphanumeric(); + $$ = new_alphanumeric("TRIM"); cbl_refer_t * how = new_reference($trim_trailing); if( ! intrinsic_call_2($$, TRIM, $r1, how) ) YYERROR; } | USUBSTR '(' alpha_val[r1] expr[r2] expr[r3] ')' { location_set(@1); - $$ = new_alphanumeric(); + $$ = new_alphanumeric("USUBSTR"); if( ! intrinsic_call_3($$, FORMATTED_DATETIME, $r1, $r2, $r3) ) YYERROR; } @@ -10462,14 +10659,14 @@ intrinsic: function_udf | intrinsic_I '(' expr[r1] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric(keyword_str($1)); if( ! intrinsic_call_1($$, $1, $r1, @r1)) YYERROR; } | intrinsic_N '(' expr[r1] ')' { location_set(@1); - $$ = new_tempnumeric_float(); + $$ = new_tempnumeric_float(keyword_str($1)); if( ! intrinsic_call_1($$, $1, $r1, @r1)) YYERROR; } @@ -10479,17 +10676,14 @@ intrinsic: function_udf auto type = intrinsic_return_type($1); switch(type) { case FldAlphanumeric: - $$ = new_alphanumeric(); + $$ = new_alphanumeric(keyword_str($1)); break; default: - if( $1 == NUMVAL || $1 == NUMVAL_F ) - { - $$ = new_temporary(FldFloat); - } - else - { - $$ = new_temporary(type); - } + if( $1 == NUMVAL || $1 == NUMVAL_F ) { + $$ = new_temporary(FldFloat, keyword_str($1)); + } else { + $$ = new_temporary(type, keyword_str($1)); + } } if( $1 == NUMVAL_F ) { if( is_literal($r1->field) && ! is_numeric($r1->field->type) ) { @@ -10504,7 +10698,7 @@ intrinsic: function_udf | intrinsic_I2 '(' expr[r1] expr[r2] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("intrinsic_I2"); if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR; } @@ -10520,7 +10714,7 @@ intrinsic: function_udf parser_intrinsic_call_0( r3->field, "__gg__current_date" ); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("DATE_TO_YYYYMMDD"); if( ! intrinsic_call_3($$, DATE_TO_YYYYMMDD, $r1, r2, r3) ) YYERROR; } @@ -10536,7 +10730,7 @@ intrinsic: function_udf parser_intrinsic_call_0( r3->field, "__gg__current_date" ); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("DATE_TO_YYYYMMDD"); if( ! intrinsic_call_3($$, DATE_TO_YYYYMMDD, $r1, $r2, r3) ) YYERROR; } @@ -10545,7 +10739,7 @@ intrinsic: function_udf expr[r2] expr[r3] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("DATE_TO_YYYYMMDD"); if( ! intrinsic_call_3($$, DATE_TO_YYYYMMDD, $r1, $r2, $r3) ) YYERROR; } @@ -10562,7 +10756,7 @@ intrinsic: function_udf parser_intrinsic_call_0( r3->field, "__gg__current_date" ); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("DAY_TO_YYYYDDD"); if( ! intrinsic_call_3($$, DAY_TO_YYYYDDD, $r1, r2, r3) ) YYERROR; } @@ -10578,7 +10772,7 @@ intrinsic: function_udf parser_intrinsic_call_0( r3->field, "__gg__current_date" ); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("DAY_TO_YYYYDDD"); if( ! intrinsic_call_3($$, DAY_TO_YYYYDDD, $r1, $r2, r3) ) YYERROR; } @@ -10587,7 +10781,7 @@ intrinsic: function_udf expr[r2] expr[r3] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("DAY_TO_YYYYDDD"); if( ! intrinsic_call_3($$, DAY_TO_YYYYDDD, $r1, $r2, $r3) ) YYERROR; } @@ -10604,7 +10798,7 @@ intrinsic: function_udf parser_intrinsic_call_0( r3->field, "__gg__current_date" ); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("YEAR_TO_YYYY"); if( ! intrinsic_call_3($$, YEAR_TO_YYYY, $r1, r2, r3) ) YYERROR; } @@ -10620,7 +10814,7 @@ intrinsic: function_udf parser_intrinsic_call_0( r3->field, "__gg__current_date" ); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("YEAR_TO_YYYY"); if( ! intrinsic_call_3($$, YEAR_TO_YYYY, $r1, $r2, r3) ) YYERROR; } @@ -10629,7 +10823,7 @@ intrinsic: function_udf expr[r2] expr[r3] ')' { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("YEAR_TO_YYYY"); if( ! intrinsic_call_3($$, YEAR_TO_YYYY, $r1, $r2, $r3) ) YYERROR; } @@ -10637,25 +10831,25 @@ intrinsic: function_udf | intrinsic_N2 '(' expr[r1] expr[r2] ')' { location_set(@1); - switch($1) - { - case ANNUITY: - $$ = new_tempnumeric_float(); - break; - case COMBINED_DATETIME: - $$ = new_tempnumeric(); - break; - case REM: - $$ = new_tempnumeric_float(); - break; - } + switch($1) { + case ANNUITY: + $$ = new_tempnumeric_float(); + break; + case COMBINED_DATETIME: + $$ = new_tempnumeric(); + break; + case REM: + $$ = new_tempnumeric_float(); + break; + } + $$->data.initial = keyword_str($1); // function name if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR; } | intrinsic_X2 '(' varg[r1] varg[r2] ')' { location_set(@1); - $$ = new_alphanumeric(); + $$ = new_alphanumeric(keyword_str($1)); if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR; } | intrinsic_locale @@ -10686,7 +10880,7 @@ numval_locale: %empty { $$.arg2 = cbl_refer_t::empty(); } | LOCALE NAME { $$.is_locale = true; $$.arg2 = NULL; - cbl_unimplemented("NUMVAL_C LOCALE"); YYERROR; + cbl_unimplemented("%<NUMVAL_C LOCALE%>"); YYERROR; } | varg { $$.is_locale = false; $$.arg2 = $1; } ; @@ -10766,65 +10960,66 @@ trim_trailing: %empty { $$ = new_literal("0"); } // Remove both intrinsic0: CURRENT_DATE { location_set(@1); - $$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE); + $$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE, "CURRENT-DATE"); parser_intrinsic_call_0( $$, "__gg__current_date" ); } | E { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("E"); parser_intrinsic_call_0( $$, "__gg__e" ); } | EXCEPTION_FILE_N { location_set(@1); - $$ = new_alphanumeric(); + $$ = new_alphanumeric("EXCEPTION-FILE-N"); intrinsic_call_0( $$, EXCEPTION_FILE_N ); } | EXCEPTION_FILE { location_set(@1); - $$ = new_alphanumeric(); + $$ = new_alphanumeric("EXCEPTION-FILE"); parser_exception_file( $$ ); } | EXCEPTION_LOCATION_N { location_set(@1); - $$ = new_alphanumeric(); + $$ = new_alphanumeric("EXCEPTION-LOCATION-N"); intrinsic_call_0( $$, EXCEPTION_LOCATION_N ); } | EXCEPTION_LOCATION { location_set(@1); - $$ = new_alphanumeric(); + $$ = new_alphanumeric("EXCEPTION-LOCATION"); intrinsic_call_0( $$, EXCEPTION_LOCATION ); } | EXCEPTION_STATEMENT { location_set(@1); - $$ = new_alphanumeric(); + $$ = new_alphanumeric("EXCEPTION-STATEMENT"); intrinsic_call_0( $$, EXCEPTION_STATEMENT ); } | EXCEPTION_STATUS { location_set(@1); - $$ = new_alphanumeric(); + $$ = new_alphanumeric("EXCEPTION-STATUS"); intrinsic_call_0( $$, EXCEPTION_STATUS ); } | PI { location_set(@1); - $$ = new_tempnumeric_float(); + $$ = new_tempnumeric_float("PI"); parser_intrinsic_call_0( $$, "__gg__pi" ); } | SECONDS_PAST_MIDNIGHT { location_set(@1); - $$ = new_tempnumeric(); + $$ = new_tempnumeric("SECONDS-PAST-MIDNIGHT"); intrinsic_call_0( $$, SECONDS_PAST_MIDNIGHT ); } | UUID4 { location_set(@1); - $$ = new_alphanumeric(); + $$ = new_alphanumeric("UUID4"); parser_intrinsic_call_0( $$, "__gg__uuid4" ); } | WHEN_COMPILED { location_set(@1); - $$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE); // Returns YYYYMMDDhhmmssss-0500 + // Returns YYYYMMDDhhmmssss-0500) + $$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE, "WHEN-COMPILED"); parser_intrinsic_call_0( $$, "__gg__when_compiled" ); } ; @@ -11234,7 +11429,7 @@ first_line_of( YYLTYPE loc ) { return loc; } -void ast_call( const YYLTYPE& loc, cbl_refer_t name, cbl_refer_t returning, +void ast_call( const YYLTYPE& loc, cbl_refer_t name, const cbl_refer_t& returning, size_t narg, cbl_ffi_arg_t args[], cbl_label_t *except, cbl_label_t *not_except, @@ -11263,6 +11458,7 @@ void ast_call( const YYLTYPE& loc, cbl_refer_t name, cbl_refer_t returning, */ static bool possible_ec() { + cbl_enabled_exceptions_t& enabled_exceptions( cdf_enabled_exceptions() ); bool format_1 = current.declaratives.has_format_1(); bool enabled = 0xFF < (current.declaratives.status() @@ -11285,6 +11481,7 @@ possible_ec() { */ static void statement_epilog( int token ) { + cbl_enabled_exceptions_t& enabled_exceptions( cdf_enabled_exceptions() ); if( possible_ec() && token != CONTINUE ) { if( enabled_exceptions.size() ) { current.declaratives_evaluate(); @@ -11326,7 +11523,7 @@ statement_begin( const YYLTYPE& loc, int token ) { struct string_match { const char *name; - string_match( const char name[] ) : name(name) {} + explicit string_match( const char name[] ) : name(name) {} bool operator()( const char input[] ) const { return strlen(name) == strlen(input) && 0 == strcasecmp(name, input); } @@ -11334,18 +11531,24 @@ struct string_match { const char * keyword_str( int token ) { - if( token == YYEOF ) return "YYEOF"; - if( token == YYEMPTY ) return "YYEMPTY"; - + switch( token ) { + case YYEOF: return "YYEOF"; + case YYEMPTY: return "YYEMPTY"; + case 256: return "YYerror"; + case 257: return "invalid token"; // YYUNDEF + } + if( token < 256 ) { static char ascii[2]; ascii[0] = token; return ascii; } - return tokens.name_of(token); + return cdf_tokens.name_of(token); } +bool iso_cobol_word( const std::string& name, bool include_context ); + /* * Return the token for the Cobol name, unless it is a function name. The * lexer uses keyword_tok to determine if what appears to be a NAME is in fact @@ -11356,15 +11559,14 @@ keyword_str( int token ) { */ // tokens.h is generated as needed from parse.h with tokens.h.gen -tokenset_t::tokenset_t() { +current_tokens_t::tokenset_t::tokenset_t() { #include "token_names.h" } -bool iso_cobol_word( const std::string& name, bool include_context ); // Look up the lowercase form of a keyword, excluding some CDF names. int -tokenset_t::find( const cbl_name_t name, bool include_intrinsics ) { +current_tokens_t::tokenset_t::find( const cbl_name_t name, bool include_intrinsics ) { static const cbl_name_t non_names[] = { // including CDF NAMES, and "SWITCH" "CHECKING", "LIST", "LOCATION", "MAP", "SWITCH", }, * const eonames = non_names + COUNT_OF(non_names); @@ -11380,9 +11582,9 @@ tokenset_t::find( const cbl_name_t name, bool include_intrinsics ) { if( dialect_ibm() ) { static const cbl_name_t ibm_non_names[] = { "RESUME", - }, * const eonames = ibm_non_names + COUNT_OF(ibm_non_names); + }, * const eoibm = ibm_non_names + COUNT_OF(ibm_non_names); - if( std::any_of(ibm_non_names, eonames, + if( std::any_of(ibm_non_names, eoibm, [candidate=name](const cbl_name_t non_name) { return 0 == strcasecmp(non_name, candidate) && strlen(non_name) == strlen(candidate); @@ -11414,12 +11616,12 @@ tokenset_t::find( const cbl_name_t name, bool include_intrinsics ) { int keyword_tok( const char * text, bool include_intrinsics ) { - return tokens.find(text, include_intrinsics); + return cdf_tokens.find(text, include_intrinsics); } static inline size_t verify_figconst( enum cbl_figconst_t figconst , size_t pos ) { - cbl_field_t *f = cbl_field_of(symbol_at(pos)); + const cbl_field_t *f = cbl_field_of(symbol_at(pos)); assert((f->attr & FIGCONST_MASK) == figconst); return pos; } @@ -11465,7 +11667,7 @@ relop_invert(relop_t op) { case ge_op: return lt_op; case gt_op: return le_op; } - cbl_errx( "%s:%d: invalid relop_t %d", __func__, __LINE__, op); + cbl_internal_error("%s:%d: invalid %<relop_t%> %d", __func__, __LINE__, op); return relop_t(0); // not reached } @@ -11606,7 +11808,7 @@ label_add( const YYLTYPE& loc, name, cbl_label_of(p)->name, cbl_label_of(p)->line); } } - struct cbl_label_t label = { type, parent, loc.last_line }; + struct cbl_label_t label = { type, parent, loc.first_line }; if( !namcpy(loc, label.name, name) ) return NULL; auto p = symbol_label_add(PROGRAM, &label); @@ -11711,7 +11913,7 @@ current_t::udf_update( const ffi_args_t *ffi_args ) { if( ! ffi_args ) return; assert(ffi_args->elems.size() < sizeof(function_descr_t::types)); - auto returning = cbl_field_of(symbol_at(L->returning)); + const auto returning = cbl_field_of(symbol_at(L->returning)); auto key = function_descr_t::init(L->name); auto func = udfs.find(key); assert(func != udfs.end()); @@ -11753,12 +11955,12 @@ current_t::udf_args_valid( const cbl_label_t *L, } size_t i = 0; - for( cbl_refer_t arg : args ) { + for( const cbl_refer_t& arg : args ) { if( arg.field ) { // else omitted auto tgt = cbl_field_of(symbol_at(udf.linkage_fields.at(i).isym)); if( ! valid_move(tgt, arg.field) ) { auto loc = symbol_field_location(field_index(arg.field)); - error_msg(loc, "FUNCTION %s arg %zu, '%s' cannot be passed to %s, type %s", + error_msg(loc, "FUNCTION %s argument %zu, '%s' cannot be passed to %s, type %s", L->name, i, arg.field->pretty_name(), tgt->pretty_name(), 3 + cbl_field_type_str(tgt->type) ); return false; @@ -11774,7 +11976,10 @@ current_t::repository_add( const char name[]) { assert( !programs.empty() ); function_descr_t arg = function_descr_t::init(name); auto parg = std::find( function_descrs, function_descrs_end, arg ); - if( parg == function_descrs_end ) return false; + if( parg == function_descrs_end ) { + dbgmsg("%s:%d: no intrinsic %s found", __func__, __LINE__, name); + return false; + } auto p = programs.top().function_repository.insert(*parg); if( yydebug ) { for( auto descr : programs.top().function_repository ) { @@ -11810,7 +12015,7 @@ function_descr_t function_descr_t::init( int isym ) { function_descr_t descr = { FUNCTION_UDF_0 }; descr.ret_type = FldInvalid; - auto L = cbl_label_of(symbol_at(isym)); + const auto L = cbl_label_of(symbol_at(isym)); bool ok = namcpy(YYLTYPE(), descr.name, L->name); gcc_assert(ok); return descr; @@ -11824,16 +12029,16 @@ arith_t::arith_t( cbl_arith_format_t format, refer_list_t * refers ) delete refers; } - -cbl_key_t::cbl_key_t( const sort_key_t& that ) +cbl_key_t::cbl_key_t( sort_key_t that ) : ascending(that.ascending) - , nfield(that.fields.size()) - , fields(NULL) -{ - if( nfield > 0 ) { - fields = new cbl_field_t* [nfield]; - std::copy(that.fields.begin(), that.fields.end(), fields); - } + , fields( that.fields.begin(), that.fields.end() ) +{} + +cbl_key_t& +cbl_key_t::operator=( const sort_key_t& that ) { + ascending = that.ascending; + fields = that.as_vector(); + return *this; } static cbl_refer_t * @@ -11939,10 +12144,10 @@ ast_divide( arith_t *arith ) { * the convenience of the parser. */ struct stringify_src_t : public cbl_string_src_t { - stringify_src_t( const refer_marked_list_t& marked = refer_marked_list_t() ) - : cbl_string_src_t( marked.marker? *marked.marker : null_reference, - marked.refers.size(), - new cbl_refer_t[marked.refers.size()] ) + stringify_src_t( const refer_marked_list_t& marked = refer_marked_list_t() ) + : cbl_string_src_t( marked.marker? *marked.marker : null_reference, + marked.refers.size(), + new cbl_refer_t[marked.refers.size()] ) { std::copy( marked.refers.begin(), marked.refers.end(), inputs ); } @@ -11956,13 +12161,13 @@ struct stringify_src_t : public cbl_string_src_t { protected: static void dump_input( const cbl_refer_t& refer ) { - yywarn( "%s:\t%s", __func__, field_str(refer.field) ); + yywarn( "%s: %s", __func__, field_str(refer.field) ); } }; void stringify( refer_collection_t *inputs, - cbl_refer_t into, cbl_refer_t pointer, + const cbl_refer_t& into, const cbl_refer_t& pointer, cbl_label_t *on_error, cbl_label_t *not_error ) { @@ -11977,7 +12182,7 @@ stringify( refer_collection_t *inputs, } void -unstringify( cbl_refer_t& src, +unstringify( const cbl_refer_t& src, refer_list_t *delimited, unstring_into_t * into, cbl_label_t *on_error, @@ -11985,6 +12190,7 @@ unstringify( cbl_refer_t& src, { size_t ndelimited = delimited? delimited->size() : 0; cbl_refer_t *pdelimited = NULL; + // cppcheck-suppress [variableScope] pdelimited points to delimiteds.data() std::vector <cbl_refer_t> delimiteds(ndelimited); if( ndelimited > 0 ) { pdelimited = use_any( delimited->refers, delimiteds ); @@ -12096,15 +12302,19 @@ lang_check_failed (const char* file, int line, const char* function) {} #pragma GCC diagnostic pop -void ast_inspect( cbl_refer_t& input, bool backward, ast_inspect_list_t& inspects ) { +void +ast_inspect( YYLTYPE loc, cbl_refer_t& input, bool backward, + cbl_inspect_opers_t& inspects ) +{ if( yydebug ) { - dbgmsg("%s:%d: INSPECT " HOST_SIZE_T_PRINT_UNSIGNED " operations on %s, line %d", - __func__, __LINE__, (fmt_size_t)inspects.size(), input.field->name, yylineno); + dbgmsg("%s:%d: INSPECT " HOST_SIZE_T_PRINT_UNSIGNED " operations on %s, " + "lines %d:%d - %d:%d", + __func__, __LINE__, + (fmt_size_t)inspects.size(), input.field->name, + loc.first_line, loc.first_column, loc.last_line, loc.last_column ); } std::for_each(inspects.begin(), inspects.end(), dump_inspect); - auto array = inspects.as_array(); - parser_inspect( input, backward, inspects.size(), array ); - delete[] array; + parser_inspect( input, backward, inspects ); } static const char * @@ -12116,28 +12326,29 @@ cbl_refer_str( char output[], const cbl_refer_t& R ) { return output; } -static void +void dump_inspect_match( const cbl_inspect_match_t& M ) { - static char fields[3][4 * 64]; - cbl_refer_str(fields[0], M.matching); - cbl_refer_str(fields[1], M.before.identifier_4); - cbl_refer_str(fields[2], M.after.identifier_4); - - yywarn( "matching %s \n\t\tbefore %s%s \n\t\tafter %s%s", - fields[0], - M.before.initial? "initial " : "", fields[1], - M.after.initial? "initial " : "", fields[2] ); + static char fields[4][4 * 64]; + cbl_refer_str(fields[0], M.match); + cbl_refer_str(fields[1], M.tally); + cbl_refer_str(fields[2], M.before.identifier_4); + cbl_refer_str(fields[3], M.after.identifier_4); + + dbgmsg( "matching %s [tally %s]\n\t\tbefore %s%s \n\t\tafter %s%s", + fields[0], fields[1], + M.before.initial? "initial " : "", fields[2], + M.after.initial? "initial " : "", fields[3] ); } static void dump_inspect_replace( const cbl_inspect_replace_t& R ) { static char fields[4][4 * 64]; - cbl_refer_str(fields[0], R.matching); + cbl_refer_str(fields[0], R.matching()); cbl_refer_str(fields[1], R.before.identifier_4); cbl_refer_str(fields[2], R.after.identifier_4); cbl_refer_str(fields[3], R.replacement); - yywarn( "matching %s \n\treplacement %s\n\t\tbefore %s%s \n\t\tafter %s%s", + dbgmsg( "matching %s \n\treplacement %s\n\t\tbefore %s%s \n\t\tafter %s%s", fields[0], fields[3], R.before.initial? "initial " : "", fields[1], R.after.initial? "initial " : "", fields[2] ); @@ -12253,13 +12464,13 @@ numstr2i( const char input[], radix_t radix ) { break; case hexadecimal_e: erc = sscanf(input, "%" GCC_PRISZ "x", &integerf); - integer = integer; + integer = integerf; real_from_integer (&output, VOIDmode, integer, UNSIGNED); break; case boolean_e: for( const char *p = input; *p != '\0'; p++ ) { if( ssize_t(8 * sizeof(integer) - 1) < p - input ) { - yywarn("'%s' was accepted as %d", input, integer); + yywarn("'%s' was accepted as %zu", input, integer); break; } switch(*p) { @@ -12269,7 +12480,7 @@ numstr2i( const char input[], radix_t radix ) { integer |= ((*p) == '0' ? 0 : 1); break; default: - yywarn("'%s' was accepted as %d", input, integer); + yywarn("'%s' was accepted as %zu", input, integer); break; } } @@ -12277,7 +12488,7 @@ numstr2i( const char input[], radix_t radix ) { return output; } if( erc == -1 ) { - yywarn("'%s' was accepted as %lld", input, output); + yywarn("'%s' was accepted as %zu", input, integer); } return output; } @@ -12303,7 +12514,7 @@ new_literal( const char initial[], enum radix_t radix ) { class is_elementary_type { // for INITIALIZE purposes bool with_filler; public: - is_elementary_type( bool with_filler ) : with_filler(with_filler) {} + explicit is_elementary_type( bool with_filler ) : with_filler(with_filler) {} bool operator()( const symbol_elem_t& elem ) const { if( elem.type != SymField ) return false; @@ -12317,7 +12528,7 @@ public: size_t end_of_group( size_t igroup ); static std::list<cbl_refer_t> -symbol_group_data_members( cbl_refer_t refer, bool with_filler ) { +symbol_group_data_members( const cbl_refer_t& refer, bool with_filler ) { std::list<cbl_refer_t> refers; refers.push_front( refer ); @@ -12325,7 +12536,7 @@ symbol_group_data_members( cbl_refer_t refer, bool with_filler ) { class refer_of : public cbl_refer_t { public: - refer_of( const cbl_refer_t& refer ) : cbl_refer_t(refer) {} + explicit refer_of( const cbl_refer_t& refer ) : cbl_refer_t(refer) {} cbl_refer_t operator()( symbol_elem_t& elem ) { this->field = cbl_field_of(&elem); // preserve subscript/refmod return *this; @@ -12349,7 +12560,7 @@ struct expand_group : public std::list<cbl_refer_t> { return cbl_refer_t(field); } bool with_filler; - expand_group( bool with_filler ) : with_filler(with_filler) {} + explicit expand_group( bool with_filler ) : with_filler(with_filler) {} void operator()( const cbl_refer_t& refer ) { assert(refer.field); @@ -12375,7 +12586,7 @@ wsclear( char ch ) { } static void -initialize_allocated( cbl_refer_t input ) { +initialize_allocated( const cbl_refer_t& input ) { cbl_num_result_t result = { truncation_e, input }; std::list<cbl_num_result_t> results; results.push_back(result); @@ -12384,13 +12595,14 @@ initialize_allocated( cbl_refer_t input ) { } static int -initialize_with( cbl_refer_t tgt ) { +initialize_with( const cbl_refer_t& tgt ) { if( tgt.field->type == FldPointer ) return ZERO; if( tgt.is_refmod_reference() ) return SPACES; return is_numeric(tgt.field)? ZERO : SPACES; } static bool +// cppcheck-suppress [passedByValue] target.refer.field is modified initialize_one( cbl_num_result_t target, bool with_filler, data_category_t value_category, const category_map_t& replacements, @@ -12460,11 +12672,11 @@ typedef std::pair<size_t, size_t> cbl_bytespan_t; * After the 1st record is initialized, copy it to the others. */ static bool -initialize_table( cbl_num_result_t target, +initialize_table( const cbl_num_result_t& target, size_t nspan, const cbl_bytespan_t spans[], const std::list<cbl_subtable_t>& subtables ) { - assert( target.refer.nsubscript == dimensions(target.refer.field) ); + assert( target.refer.nsubscript() == dimensions(target.refer.field) ); const cbl_refer_t& src( target.refer ); size_t n( src.field->occurs.ntimes()); assert( 0 < n ); @@ -12480,17 +12692,17 @@ static cbl_refer_t synthesize_table_refer( cbl_refer_t tgt ) { // For a table, use supplied subscripts or start with 1. auto ndim( dimensions(tgt.field) ); - if( tgt.nsubscript < ndim ) { // it's an incomplete table + if( tgt.nsubscript() < ndim ) { // it's an incomplete table std::vector <cbl_refer_t> subscripts(ndim); for( size_t i=0; i < ndim; i++ ) { - if( i < tgt.nsubscript ) { + if( i < tgt.nsubscript() ) { subscripts[i] = tgt.subscripts[i]; continue; } subscripts[i].field = new_tempnumeric(); parser_set_numeric(subscripts[i].field, 1); } - return cbl_refer_t( tgt.field, subscripts.size(), subscripts.data() ); + return cbl_refer_t( tgt.field, subscripts ); } return tgt; } @@ -12500,7 +12712,7 @@ group_offset( const cbl_field_t *field ) { if( field->parent ) { auto e = symbol_at(field->parent); if( e->type == SymField ) { - auto parent = cbl_field_of(e); + const auto parent = cbl_field_of(e); return field->offset - parent->offset; } } @@ -12514,7 +12726,7 @@ initialize_statement( const cbl_num_result_t& target, bool with_filler, size_t depth = 0 ) { const cbl_refer_t& tgt( target.refer ); - assert(dimensions(tgt.field) == tgt.nsubscript || 0 < depth); + assert(dimensions(tgt.field) == tgt.nsubscript() || 0 < depth); assert(!is_literal(tgt.field)); if( tgt.field->type == FldGroup ) { @@ -12551,7 +12763,7 @@ initialize_statement( const cbl_num_result_t& target, bool with_filler, if( fOK && is_table(tgt.field) ) { cbl_num_result_t output = { target.rounded, synthesize_table_refer(tgt) }; - if( tgt.nsubscript < output.refer.nsubscript ) { // tgt is whole table + if( tgt.nsubscript() < output.refer.nsubscript() ) { // tgt is whole table std::list<field_span_t> field_spans; static const field_span_t empty_span = { NULL, NULL }; field_span_t span = empty_span; @@ -12662,17 +12874,7 @@ static void initialize_statement( std::list<cbl_num_result_t>& tgts, bool with_filler, data_category_t value_category, const category_map_t& replacements) { - - bool is_refmod = std::any_of( tgts.begin(), tgts.end(), - []( const auto& tgt ) { - return tgt.refer.is_refmod_reference(); - } ); - if( false && is_refmod ) { // refmod seems valid per ISO - dbgmsg("INITIALIZE cannot initialize a refmod"); - return; - } - - for( auto tgt : tgts ) { + for( const auto& tgt : tgts ) { initialize_statement( tgt, with_filler, value_category, replacements ); } @@ -12683,13 +12885,11 @@ static void dump_inspect_oper( const cbl_inspect_oper_t& op ) { dbgmsg("\t%s: " HOST_SIZE_T_PRINT_UNSIGNED " \"matches\", " HOST_SIZE_T_PRINT_UNSIGNED " \"replaces\"", - bound_str(op.bound), - op.matches? (fmt_size_t)op.n_identifier_3 : 0, - op.replaces? (fmt_size_t)op.n_identifier_3 : 0); - if( op.matches ) - std::for_each(op.matches, op.matches + op.n_identifier_3, dump_inspect_match); - if( op.replaces ) - std::for_each(op.replaces, op.replaces + op.n_identifier_3, dump_inspect_replace); + bound_str(op.bound), + (fmt_size_t)op.matches.size(), + (fmt_size_t)op.replaces.size()); + std::for_each(op.matches.begin(), op.matches.end(), dump_inspect_match); + std::for_each(op.replaces.begin(), op.replaces.end(), dump_inspect_replace); } #pragma GCC diagnostic push @@ -12706,14 +12906,14 @@ dump_inspect( const cbl_inspect_t& I ) { } else { fprintf( stderr, "\tREPLACING:\n" ); } - std::for_each( I.opers, I.opers + I.nbound, dump_inspect_oper ); + std::for_each( I.begin(), I.end(), dump_inspect_oper ); } #pragma GCC diagnostic pop #include <iterator> struct declarative_file_list_t : protected cbl_declarative_t { - declarative_file_list_t( const cbl_declarative_t& d ) + explicit declarative_file_list_t( const cbl_declarative_t& d ) : cbl_declarative_t(d) { if( nfile > 0 ) @@ -12738,7 +12938,7 @@ operator<<( std::ostream& os, const declarative_file_list_t& dcl ) { static declarative_file_list_t file_list_of( const cbl_declarative_t& dcl ) { - return dcl; + return declarative_file_list_t(dcl); } std::ostream& @@ -12810,7 +13010,7 @@ cbl_file_t::validate_key( const cbl_file_key_t& key ) const { bool cbl_file_t::validate() const { - size_t members[] = { user_status, vsam_status, record_length }; + const size_t members[] = { user_status, vsam_status, record_length }; bool tf = true; for( auto isym : members ) { @@ -12857,6 +13057,34 @@ cbl_figconst_of( const char *value ) { return p == eovalues? normal_value_e : p->type; } +int +cbl_figconst_tok( const char *value ) { + struct values_t { + const char *value; int token; + } static const values[] = { + { constant_of(constant_index(ZERO))->data.initial, ZERO }, + { constant_of(constant_index(SPACES))->data.initial, SPACES }, + { constant_of(constant_index(HIGH_VALUES))->data.initial, HIGH_VALUES }, + { constant_of(constant_index(LOW_VALUES))->data.initial, LOW_VALUES }, + { constant_of(constant_index(QUOTES))->data.initial, QUOTES }, + { constant_of(constant_index(NULLS))->data.initial, NULLS }, + }, *eovalues = values + COUNT_OF(values); + + auto p = std::find_if( values, eovalues, + [value]( const values_t& elem ) { + return elem.value == value; + } ); + + return p == eovalues? 0 : p->token; +} + +const cbl_field_t * +cbl_figconst_field_of( const char *value ) { + int token = cbl_figconst_tok(value); + return token == 0 ? nullptr : constant_of(constant_index(token)); +} + + cbl_field_attr_t literal_attr( const char prefix[] ) { switch(strlen(prefix)) { @@ -12883,7 +13111,7 @@ literal_attr( const char prefix[] ) { } // must be [BN]X - cbl_internal_error("'%s': invalid literal prefix", prefix); + cbl_internal_error("invalid literal prefix: %qs", prefix); gcc_unreachable(); return none_e; } @@ -12920,10 +13148,22 @@ mode_syntax_only() { void cobol_dialect_set( cbl_dialect_t dialect ) { - cbl_dialect = dialect; - if( dialect & dialect_ibm_e ) cobol_gcobol_feature_set(feature_embiggen_e); + switch(dialect) { + case dialect_gcc_e: + break; + case dialect_ibm_e: + cobol_gcobol_feature_set(feature_embiggen_e); + break; + case dialect_mf_e: + break; + case dialect_gnu_e: + if( 0 == (cbl_dialects & dialect) ) { // first time + cdf_tokens.equate(YYLTYPE(), "BINARY-DOUBLE", "BINARY-C-LONG"); + } + break; + } + cbl_dialects |= dialect; } -cbl_dialect_t cobol_dialect() { return cbl_dialect; } static bool internal_ebcdic_locked = false; @@ -12981,7 +13221,7 @@ literal_refmod_valid( YYLTYPE loc, const cbl_refer_t& r ) { if( --edge < r.field->data.capacity ) return true; } // len < 0 or not: 0 < from + len <= capacity - auto loc = symbol_field_location(field_index(r.field)); + loc = symbol_field_location(field_index(r.field)); error_msg(loc, "%s(%zu:%zu) out of bounds, " "size is %u", r.field->name, @@ -13004,19 +13244,22 @@ literal_subscript_oob( const cbl_refer_t& r, size_t& isub ); static bool literal_subscripts_valid( YYLTYPE loc, const cbl_refer_t& name ) { - static char subs[ 7 * 32 ], *esub = subs + sizeof(subs); - char *p = subs; size_t isub; - // Find subscript in the supplied refer + // Report any out-of-bound subscript. const cbl_field_t *oob = literal_subscript_oob(name, isub); if( oob ) { - const char *sep = ""; - for( auto r = name.subscripts; r < name.subscripts + name.nsubscript; r++ ) { - snprintf( p, esub - p, "%s%s", sep, nice_name_of(r->field) ); - sep = " "; - } - + std::string sep(""); + std::string subscript_names = + std::accumulate( name.subscripts.begin(), + name.subscripts.end(), + std::string(), + [&sep]( std::string acc, const auto& sub ) { + acc += sep; + sep = " "; + return acc + nice_name_of(sub.field); + } ); + const char *upper_phrase = ""; if( ! oob->occurs.bounds.fixed_size() ) { static char ub[32] = "boo"; @@ -13027,8 +13270,8 @@ literal_subscripts_valid( YYLTYPE loc, const cbl_refer_t& name ) { // X(0): subscript 1 of for out of range for 02 X OCCURS 4 to 6 error_msg(loc, "%s(%s): subscript %zu out of range " - "for %s %s OCCURS %lu%s", - oob->name, subs, 1 + isub, + "for %s %s OCCURS %zu%s", + oob->name, subscript_names.c_str(), 1 + isub, oob->level_str(), oob->name, oob->occurs.bounds.lower, upper_phrase ); return false; @@ -13050,14 +13293,14 @@ subscript_dimension_error( YYLTYPE loc, size_t nsub, const cbl_refer_t *scalar ) } static void -reject_refmod( YYLTYPE loc, cbl_refer_t scalar ) { +reject_refmod( YYLTYPE loc, const cbl_refer_t& scalar ) { if( scalar.is_refmod_reference() ) { error_msg(loc, "%s cannot be reference-modified here", scalar.name()); } } static bool -require_pointer( YYLTYPE loc, cbl_refer_t scalar ) { +require_pointer( YYLTYPE loc, const cbl_refer_t& scalar ) { if( scalar.field->type != FldPointer ) { error_msg(loc, "%s must have USAGE POINTER", scalar.name()); return false; @@ -13066,7 +13309,7 @@ require_pointer( YYLTYPE loc, cbl_refer_t scalar ) { } static bool -require_numeric( YYLTYPE loc, cbl_refer_t scalar ) { +require_numeric( YYLTYPE loc, const cbl_refer_t& scalar ) { if( ! is_numeric(scalar.field) ) { error_msg(loc, "%s must have numeric USAGE", scalar.name()); return false; @@ -13075,7 +13318,7 @@ require_numeric( YYLTYPE loc, cbl_refer_t scalar ) { } static bool -require_integer( YYLTYPE loc, cbl_refer_t scalar ) { +require_integer( YYLTYPE loc, const cbl_refer_t& scalar ) { if( is_literal(scalar.field) ) { if( ! is_integer_literal(scalar.field) ) { error_msg(loc, "numeric literal '%s' must be an integer", diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h index 0369f7b..03cb0a0 100644 --- a/gcc/cobol/parse_ante.h +++ b/gcc/cobol/parse_ante.h @@ -28,9 +28,9 @@ * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ -#include <assert.h> -#include <string.h> -#include <stdio.h> +#include <cassert> +#include <cstring> +#include <cstdio> #include <algorithm> #include <list> @@ -47,9 +47,6 @@ #pragma GCC diagnostic push #pragma GCC diagnostic ignored "-Wmissing-field-initializers" -extern void declarative_runtime_match(cbl_field_t *declaratives, - cbl_label_t *lave ); - extern YYLTYPE yylloc; extern int yylineno, yyleng, yychar; @@ -73,7 +70,7 @@ void apply_declaratives(); const char * keyword_str( int token ); void labels_dump(); -cbl_dialect_t cbl_dialect; +unsigned int cbl_dialects; size_t cbl_gcobol_features; static enum cbl_division_t current_division; @@ -105,14 +102,14 @@ void input_file_status_notify(); (Current).last_column = YYRHSLOC (Rhs, 0).last_column; \ } \ location_dump("parse.c", __LINE__, "current", (Current)); \ - gcc_location_set( location_set(Current) ); \ input_file_status_notify(); \ + location_set(Current); \ } while (0) int yylex(void); extern int yydebug; -#include <stdarg.h> +#include <cstdarg> const char * consistent_encoding_check( const YYLTYPE& loc, const char input[] ) { @@ -213,6 +210,9 @@ in_file_section(void) { return current_data_section == file_datasect_e; } static cbl_refer_t * intrinsic_inconsistent_parameter( size_t n, cbl_refer_t *args ); +static int +intrinsic_token_of( const char name[] ); + static inline bool namcpy(const YYLTYPE& loc, cbl_name_t tgt, const char *src ) { // snprintf(3): writes at most size bytes (including the terminating NUL byte) @@ -226,7 +226,13 @@ namcpy(const YYLTYPE& loc, cbl_name_t tgt, const char *src ) { } cbl_field_t * -new_alphanumeric( size_t capacity = MAXIMUM_ALPHA_LENGTH ); +new_alphanumeric( size_t capacity = MAXIMUM_ALPHA_LENGTH, + const cbl_name_t name = nullptr ); + +static inline cbl_field_t * +new_alphanumeric( const cbl_name_t name ) { + return new_alphanumeric(MAXIMUM_ALPHA_LENGTH, name); +} static inline cbl_refer_t * new_reference( enum cbl_field_type_t type, const char *initial ) { @@ -241,9 +247,9 @@ new_reference_like( const cbl_field_t& skel ) { return new cbl_refer_t( new_temporary_like(skel) ); } -static void reject_refmod( YYLTYPE loc, cbl_refer_t ); -static bool require_pointer( YYLTYPE loc, cbl_refer_t ); -static bool require_integer( YYLTYPE loc, cbl_refer_t ); +static void reject_refmod( YYLTYPE loc, const cbl_refer_t& ); +static bool require_pointer( YYLTYPE loc, const cbl_refer_t& ); +static bool require_integer( YYLTYPE loc, const cbl_refer_t& ); struct cbl_field_t * constant_of( size_t isym ); @@ -286,7 +292,7 @@ struct evaluate_elem_t { relop_t oper; public: cbl_field_t *subject, *object, *cond; - case_t( cbl_field_t * subject ) + explicit case_t( cbl_field_t * subject ) : oper(eq_op) , subject(subject) , object(NULL) @@ -325,15 +331,14 @@ struct evaluate_elem_t { explicit evaluate_elem_t( const char skel[] ) : nother(0) + , label{LblEvaluate} , result( keep_temporary(FldConditional) ) , pcase( cases.end() ) { - static const cbl_label_t protolabel = { LblEvaluate }; - label = protolabel; label.line = yylineno; if( -1 == snprintf(label.name, sizeof(label.name), "%.*s_%d", (int)sizeof(label.name)-6, skel, yylineno) ) { - yyerror("could not create unique label '%s_%d' because it is too long", + yyerror("could not create unique label %<%s_%d%> because it is too long", skel, yylineno); } } @@ -364,13 +369,14 @@ struct evaluate_elem_t { static class file_delete_args_t { cbl_file_t *file; public: + file_delete_args_t() : file(nullptr) {} void init( cbl_file_t *file ) { this->file = file; } - bool ready() const { return file != NULL; } + bool ready() const { return file != nullptr; } void call_parser_file_delete( bool sequentially ) { parser_file_delete(file, sequentially); - file = NULL; + file = nullptr; } } file_delete_args; @@ -386,7 +392,7 @@ static struct file_read_args_t { void init( struct cbl_file_t *file, - cbl_refer_t record, + const cbl_refer_t& record, cbl_refer_t *read_into, int where ) { this->file = file; @@ -435,7 +441,7 @@ public: this->file = file; } bool ready() const { return file != NULL; } - void call_parser_return_start(cbl_refer_t into = cbl_refer_t() ) { + void call_parser_return_start(const cbl_refer_t& into = cbl_refer_t() ) { parser_return_start(file, into); file = NULL; } @@ -445,17 +451,18 @@ static class file_rewrite_args_t { cbl_file_t *file; cbl_field_t *record; public: + file_rewrite_args_t() : file(nullptr), record(nullptr) {} void init( cbl_file_t *file, cbl_field_t *record ) { this->file = file; this->record = record; } - bool ready() const { return file != NULL; } + bool ready() const { return file != nullptr; } void call_parser_file_rewrite( bool sequentially ) { sequentially = sequentially || file->access == file_access_seq_e; if( file->access == file_access_rnd_e ) sequentially = false; parser_file_rewrite(file, record, sequentially); - file = NULL; - record = NULL; + file = nullptr; + record = nullptr; } } file_rewrite_args; @@ -484,21 +491,22 @@ static class file_write_args_t { cbl_refer_t *advance; public: file_write_args_t() - : file(NULL) + : file(nullptr) + , data_source(nullptr) , after(false) - , advance(NULL) + , advance(nullptr) {} cbl_file_t * init( cbl_file_t *file, cbl_field_t *data_source, bool after, - cbl_refer_t *advance ) { + const cbl_refer_t *advance ) { this->file = file; this->data_source = data_source; this->after = after; this->advance = new cbl_refer_t(*advance); return this->file; } - bool ready() const { return file != NULL; } + bool ready() const { return file != nullptr; } void call_parser_file_write( bool sequentially ) { sequentially = sequentially || file->access == file_access_seq_e; parser_file_write(file, data_source, after, *advance, sequentially); @@ -532,7 +540,7 @@ struct arith_t { cbl_refer_t remainder; cbl_label_t *on_error, *not_error; - arith_t( cbl_arith_format_t format ) + explicit arith_t( cbl_arith_format_t format ) : format(format), on_error(NULL), not_error(NULL) {} arith_t( cbl_arith_format_t format, refer_list_t * refers ); @@ -616,7 +624,7 @@ class eval_subject_t { void new_object_labels(); public: eval_subject_t(); - void append( cbl_refer_t field ) { + void append( const cbl_refer_t& field ) { columns.push_back(field); pcol = columns.begin(); } @@ -747,6 +755,7 @@ public: static void dump_inspect( const cbl_inspect_t& i ); +void dump_inspect_match( const cbl_inspect_match_t& M ); struct perform_t { struct cbl_perform_tgt_t tgt; @@ -786,11 +795,10 @@ struct perform_t { cbl_refer_t table; } search; - perform_t( cbl_label_t *from, cbl_label_t *to = NULL ) + explicit perform_t( cbl_label_t *from, cbl_label_t *to = NULL ) : tgt( from, to ), before(true) - { - search = {}; - } + , search() + {} ~perform_t() { varys.clear(); } cbl_field_t * until() { assert(!varys.empty()); @@ -889,7 +897,7 @@ static struct cbl_label_t * paragraph_reference( const char name[], size_t section ); static inline void -list_add( list<cbl_num_result_t>& list, cbl_refer_t refer, int round ) { +list_add( list<cbl_num_result_t>& list, const cbl_refer_t& refer, int round ) { struct cbl_num_result_t arg = { static_cast<cbl_round_t>(round), refer }; list.push_back(arg); } @@ -927,171 +935,17 @@ teed_up_names() { return name_queue_t::namelist_of( name_queue.peek() ); } -class tokenset_t { - // token_names is initialized from a generated header file. - std::vector<const char *>token_names; // position indicates token value - std::map <std::string, int> tokens; // aliases - std::set<std::string> cobol_words; // Anything in COBOL-WORDS may appear only once. - public: - static std::string - lowercase( const cbl_name_t name ) { - cbl_name_t lname; - std::transform(name, name + strlen(name) + 1, lname, ftolower); - return lname; - } - static std::string - uppercase( const cbl_name_t name ) { - cbl_name_t uname; - std::transform(name, name + strlen(name) + 1, uname, ftoupper); - return uname; - } - - public: - tokenset_t(); - int find( const cbl_name_t name, bool include_intrinsics ); - - bool equate( const YYLTYPE& loc, int token, - const cbl_name_t name, const cbl_name_t verb = "EQUATE") { - auto lname( lowercase(name) ); - auto cw = cobol_words.insert(lname); - if( ! cw.second ) { - error_msg(loc, "COBOL-WORDS %s: %s may appear but once", verb, name); - return false; - } - auto p = tokens.find(lowercase(name)); - bool fOK = p == tokens.end(); - if( fOK ) { // name not already in use - tokens[lname] = token; - dbgmsg("%s:%d: %d has alias %s", __func__, __LINE__, token, name); - } else { - error_msg(loc, "%s: %s already defined as a token", verb, name); - } - return fOK; - } - bool undefine( const YYLTYPE& loc, - const cbl_name_t name, const cbl_name_t verb = "UNDEFINE" ) { - auto lname( lowercase(name) ); - auto cw = cobol_words.insert(lname); - if( ! cw.second ) { - error_msg(loc, "COBOL-WORDS %s: %s may appear but once", verb, name); - return false; - } - - // Do not erase generic, multi-type tokens COMPUTATIONAL and BINARY_INTEGER. - if( binary_integer_usage_of(name) ) { - dbgmsg("%s:%d: generic %s remains valid as a token", __func__, __LINE__, name); - return true; - } - - auto p = tokens.find(lname); - bool fOK = p != tokens.end(); - if( fOK ) { // name in use - tokens.erase(p); - } else { - error_msg(loc, "%s: %s not defined as a token", verb, name); - } - dbgmsg("%s:%d: %s removed as a valid token name", __func__, __LINE__, name); - return fOK; - } - - bool substitute( const YYLTYPE& loc, - const cbl_name_t extant, int token, const cbl_name_t name ) { - return - equate( loc, token, name, "SUBSTITUTE" ) - && - undefine( loc, extant, "SUBSTITUTE" ); - } - bool reserve( const YYLTYPE& loc, const cbl_name_t name ) { - auto lname( lowercase(name) ); - auto cw = cobol_words.insert(lname); - if( ! cw.second ) { - error_msg(loc, "COBOL-WORDS RESERVE: %s may appear but once", name); - return false; - } - tokens[lname] = -42; - return true; - } - int redefined_as( const cbl_name_t name ) { - auto lname( lowercase(name) ); - if( cobol_words.find(lname) != cobol_words.end() ) { - auto p = tokens.find(lname); - if( p != tokens.end() ) { - return p->second; - } - } - return 0; - } - const char * name_of( int tok ) const { - tok -= (255 + 3); - gcc_assert(0 <= tok && size_t(tok) < token_names.size()); - return token_names[tok]; - } -}; - -class current_tokens_t { - tokenset_t tokens; - public: - current_tokens_t() {} - int find( const cbl_name_t name, bool include_intrinsics ) { - return tokens.find(name, include_intrinsics); - } - bool equate( const YYLTYPE& loc, cbl_name_t keyword, const cbl_name_t alias ) { - int token; - if( 0 == (token = binary_integer_usage_of(keyword)) ) { - if( 0 == (token = keyword_tok(keyword)) ) { - error_msg(loc, "EQUATE %s: not a valid token", keyword); - return false; - } - } - auto name = keyword_alias_add(tokens.uppercase(keyword), - tokens.uppercase(alias)); - if( name != keyword ) { - error_msg(loc, "EQUATE: %s is already an alias for %s", alias, name.c_str()); - return false; - } - return tokens.equate(loc, token, alias); - } - bool undefine( const YYLTYPE& loc, cbl_name_t keyword ) { - return tokens.undefine(loc, keyword); - } - bool substitute( const YYLTYPE& loc, cbl_name_t keyword, const cbl_name_t alias ) { - int token; - if( 0 == (token = binary_integer_usage_of(keyword)) ) { - if( 0 == (token = keyword_tok(keyword)) ) { - error_msg(loc, "SUBSTITUTE %s: not a valid token", keyword); - return false; - } - } - auto name = keyword_alias_add(tokens.uppercase(keyword), - tokens.uppercase(alias)); - if( name != keyword ) { - error_msg(loc, "SUBSTITUTE: %s is already an alias for %s", alias, name.c_str()); - return false; - } - - dbgmsg("%s:%d: %s (%d) will have alias %s", __func__, __LINE__, keyword, token, alias); - return tokens.substitute(loc, keyword, token, alias); - } - bool reserve( const YYLTYPE& loc, const cbl_name_t name ) { - return tokens.reserve(loc, name); - } - int redefined_as( const cbl_name_t name ) { - return tokens.redefined_as(name); - } - const char * name_of( int tok ) const { - return tokens.name_of(tok); - } -} tokens; +#define cdf_tokens cdf_current_tokens() int redefined_token( const cbl_name_t name ) { - return tokens.redefined_as(name); + return cdf_tokens.redefined_as(name); } struct file_list_t { list<cbl_file_t*> files; file_list_t() {} - file_list_t( cbl_file_t* file ) { + explicit file_list_t( cbl_file_t* file ) { files.push_back(file); } file_list_t( file_list_t& that ) : files(that.files.size()) { @@ -1105,10 +959,15 @@ struct file_list_t { struct field_list_t { list<cbl_field_t*> fields; - field_list_t( cbl_field_t *field ) { + field_list_t() {} + explicit field_list_t( cbl_field_t *field ) { fields.push_back(field); } - explicit field_list_t() {} + std::vector<const cbl_field_t*> + as_vector() const { + std::vector<const cbl_field_t*> output( fields.begin(), fields.end() ); + return output; + } }; cbl_field_t ** @@ -1135,7 +994,7 @@ cbl_file_t ** struct refer_list_t { list<cbl_refer_t> refers; - refer_list_t( cbl_refer_t *refer ) { + explicit refer_list_t( cbl_refer_t *refer ) { if( refer ) { refers.push_back(*refer); delete refer; @@ -1157,13 +1016,20 @@ struct refer_list_t { refers.clear(); return tgt; } + std::vector<cbl_refer_t> + vectorize() { + std::vector<cbl_refer_t> tgt(refers.size()); + std::copy(refers.begin(), refers.end(), tgt.begin()); + refers.clear(); + return tgt; + } }; struct refer_marked_list_t : public refer_list_t { cbl_refer_t *marker; refer_marked_list_t() : refer_list_t(NULL), marker(NULL) {} - refer_marked_list_t( cbl_refer_t *marker, refer_list_t *refers ) + refer_marked_list_t( cbl_refer_t *marker, const refer_list_t *refers ) : refer_list_t(*refers), marker(marker) {} refer_marked_list_t( cbl_refer_t *marker, cbl_refer_t *input ) : refer_list_t(input) @@ -1183,7 +1049,7 @@ struct refer_marked_list_t : public refer_list_t { struct refer_collection_t { list<refer_marked_list_t> lists; - refer_collection_t( const refer_marked_list_t& marked_list ) + explicit refer_collection_t( const refer_marked_list_t& marked_list ) { lists.push_back( marked_list ); } @@ -1209,48 +1075,13 @@ struct refer_collection_t { } }; -struct ast_inspect_oper_t { - cbl_inspect_bound_t bound; // CHARACTERS/ALL/LEADING/FIRST - std::list<cbl_inspect_match_t> matches; - std::list<cbl_inspect_replace_t> replaces; - -ast_inspect_oper_t( const cbl_inspect_match_t& match, - cbl_inspect_bound_t bound = bound_characters_e ) - : bound(bound) - { - matches.push_back(match); - } - ast_inspect_oper_t( const cbl_inspect_replace_t& replace, - cbl_inspect_bound_t bound = bound_characters_e ) - : bound(bound) - { - replaces.push_back(replace); - } -}; - -struct ast_inspect_t : public std::list<cbl_inspect_oper_t> { - cbl_refer_t tally; // field is NULL for REPLACING - const std::list<cbl_inspect_oper_t>& opers() const { return *this; } -}; - -struct ast_inspect_list_t : public std::list<cbl_inspect_t> { - ast_inspect_list_t( const cbl_inspect_t& insp ) { - push_back(insp); - } - - cbl_inspect_t * as_array() { - cbl_inspect_t *output = new cbl_inspect_t[ size() ]; - std::copy( begin(), end(), output ); - return output; - } -}; - -void ast_inspect( cbl_refer_t& input, bool backward, ast_inspect_list_t& inspects ); +void ast_inspect( YYLTYPE loc, cbl_refer_t& input, bool backward, + cbl_inspect_opers_t& inspects ); template <typename E> struct elem_list_t { list<E*> elems; - elem_list_t( E *elem ) { + explicit elem_list_t( E *elem ) { elems.push_back(elem); } void clear() { @@ -1275,7 +1106,7 @@ template <typename L, typename E> struct unstring_tgt_t { cbl_refer_t *tgt, *delimiter, *count; - unstring_tgt_t( cbl_refer_t *tgt, + explicit unstring_tgt_t( cbl_refer_t *tgt, cbl_refer_t *delimiter = NULL, cbl_refer_t *count = NULL ) : tgt(tgt), delimiter(delimiter), count(count) @@ -1299,7 +1130,7 @@ private: struct unstring_tgt_list_t { list<unstring_tgt_t> unstring_tgts; - unstring_tgt_list_t( unstring_tgt_t *unstring_tgt ) { + explicit unstring_tgt_list_t( unstring_tgt_t *unstring_tgt ) { unstring_tgts.push_back(*unstring_tgt); delete unstring_tgt; } @@ -1321,7 +1152,7 @@ struct unstring_tgt_list_t { struct unstring_into_t : public unstring_tgt_list_t { cbl_refer_t pointer, tally; - unstring_into_t( unstring_tgt_list_t *tgt_list, + explicit unstring_into_t( unstring_tgt_list_t *tgt_list, cbl_refer_t *pointer = NULL, cbl_refer_t *tally = NULL ) : unstring_tgt_list_t(*tgt_list) @@ -1337,7 +1168,7 @@ struct unstring_into_t : public unstring_tgt_list_t { struct ffi_args_t { list<cbl_ffi_arg_t> elems; - ffi_args_t( cbl_ffi_arg_t *arg ) { + explicit ffi_args_t( cbl_ffi_arg_t *arg ) { this->push_back(arg); } @@ -1413,8 +1244,8 @@ struct file_sort_io_t { file_list_t file_list; cbl_perform_tgt_t tgt; - file_sort_io_t( file_list_t& files ) : file_list(files) {} - file_sort_io_t( cbl_perform_tgt_t& tgt ) : tgt(tgt.from(), tgt.to()) {} + explicit file_sort_io_t( file_list_t& files ) : file_list(files) {} + explicit file_sort_io_t( cbl_perform_tgt_t& tgt ) : tgt(tgt.from(), tgt.to()) {} size_t nfile() const { return file_list.files.size(); } }; @@ -1429,14 +1260,14 @@ struct merge_t { cbl_perform_tgt_t tgt; list<cbl_file_t*> outputs; - merge_t( cbl_file_t *input ) : master(input), type(output_unknown_e) {} + explicit merge_t( cbl_file_t *input ) : master(input), type(output_unknown_e) {} }; static list<merge_t> merges; static inline merge_t& merge_alloc( cbl_file_t *file ) { - merges.push_back(file); + merges.push_back(merge_t(file)); return merges.back(); } @@ -1457,7 +1288,7 @@ static list<cbl_refer_t> lhs; struct vargs_t { std::list<cbl_refer_t> args; vargs_t() {} - vargs_t( struct cbl_refer_t *p ) { args.push_back(*p); delete p; } + explicit vargs_t( struct cbl_refer_t *p ) { args.push_back(*p); delete p; } void push_back( cbl_refer_t *p ) { args.push_back(*p); delete p; } }; @@ -1476,12 +1307,13 @@ class prog_descr_t { std::set<std::string> call_targets, subprograms; public: std::set<function_descr_t> function_repository; - size_t program_index, declaratives_index; + size_t program_index; cbl_label_t *declaratives_eval, *paragraph, *section; const char *collating_sequence; struct locale_t { cbl_name_t name; const char *os_name; - locale_t(const cbl_name_t name = NULL, const char *os_name = NULL) + locale_t() : name(""), os_name(nullptr) {} + locale_t(const cbl_name_t name, const char *os_name) : name(""), os_name(os_name) { if( name ) { bool ok = namcpy(YYLTYPE(), this->name, name); @@ -1489,19 +1321,15 @@ class prog_descr_t { } } } locale; - cbl_call_convention_t call_convention; cbl_options_t options; - prog_descr_t( size_t isymbol ) + explicit prog_descr_t( size_t isymbol ) : program_index(isymbol) - , declaratives_index(0) , declaratives_eval(NULL) , paragraph(NULL) , section(NULL) , collating_sequence(NULL) - { - call_convention = current_call_convention(); - } + {} std::set<std::string> external_targets() { std::set<std::string> externals; @@ -1590,24 +1418,13 @@ static cbl_label_t * implicit_section(); class program_stack_t : protected std::stack<prog_descr_t> { struct pending_t { - cbl_call_convention_t call_convention; bool initial; - pending_t() - : call_convention(cbl_call_convention_t(0)) - , initial(false) - {} + pending_t() : initial(false) {} } pending; public: - cbl_call_convention_t - pending_call_convention( cbl_call_convention_t convention ) { - return pending.call_convention = convention; - } bool pending_initial() { return pending.initial = true; } void push( prog_descr_t descr ) { - cbl_call_convention_t current_call_convention = cbl_call_cobol_e; - if( !empty() ) current_call_convention = top().call_convention; - descr.call_convention = current_call_convention; std::stack<prog_descr_t>& me(*this); me.push(descr); } @@ -1633,9 +1450,6 @@ class program_stack_t : protected std::stack<prog_descr_t> { } void apply_pending() { - if( size() == 1 && 0 != pending.call_convention ) { - top().call_convention = pending.call_convention; - } if( pending.initial ) { auto e = symbol_at(top().program_index); auto prog(cbl_label_of(e)); @@ -1643,11 +1457,12 @@ class program_stack_t : protected std::stack<prog_descr_t> { } } + // cppcheck-suppress-begin useStlAlgorithm cbl_label_t *first_declarative() { auto eval = top().declaratives_eval; if( eval ) return eval; // scan stack container for declaratives - for( auto& prog : c ) { + for( const auto& prog : c ) { if( prog.declaratives_eval ) { eval = prog.declaratives_eval; break; @@ -1655,6 +1470,7 @@ class program_stack_t : protected std::stack<prog_descr_t> { } return eval; } + // cppcheck-suppress-end useStlAlgorithm }; struct rel_part_t { @@ -1662,9 +1478,13 @@ struct rel_part_t { bool has_relop, invert; relop_t relop; - rel_part_t( cbl_refer_t *operand = NULL, - relop_t relop = relop_t(-1), - bool invert = false ) + rel_part_t() + : operand(nullptr), + has_relop(false), + invert(false), + relop(relop_t(-1)) + {} + rel_part_t( cbl_refer_t *operand, relop_t relop, bool invert ) : operand(operand), has_relop(relop != -1), invert(invert), @@ -1698,7 +1518,7 @@ struct rel_part_t { class log_expr_t { cbl_field_t *orable, *andable; public: - log_expr_t( cbl_field_t *init ) : orable(NULL), andable(init) { + explicit log_expr_t( cbl_field_t *init ) : orable(NULL), andable(init) { if( ! is_conditional(init) ) { dbgmsg("%s:%d: logic error: %s is not a truth value", __func__, __LINE__, name_of(init)); @@ -1857,6 +1677,10 @@ static class current_t { class declaratives_t : protected declaratives_list_t { struct file_exception_t { ec_type_t type; uint32_t file; + file_exception_t() : type(ec_none_e), file(0) {} + file_exception_t(ec_type_t type, uint32_t file) + : type(type), file(file) + {} bool operator<( const file_exception_t& that ) const { if( type == that.type ) return file < that.file; return type < that.type; @@ -1864,9 +1688,11 @@ static class current_t { }; std::set<file_exception_t> file_exceptions; public: + declaratives_t() {} // current compiled data for enabled ECs and Declaratives, used by library. struct runtime_t { tree ena, dcl; + runtime_t() : ena(nullptr), dcl(nullptr) {} } runtime; bool empty() const { @@ -1886,7 +1712,7 @@ static class current_t { } for( auto f = declarative.files; f && f < declarative.files + declarative.nfile; f++ ) { - file_exception_t ex = { declarative.type, *f }; + file_exception_t ex( declarative.type, *f ); auto result = file_exceptions.insert(ex); if( ! result.second ) { yyerror("%s defined twice for %s", @@ -1899,6 +1725,7 @@ static class current_t { return true; } + // cppcheck-suppress-begin useStlAlgorithm uint32_t status() const { uint32_t status_word = 0; for( auto dcl : *this ) { @@ -1906,6 +1733,7 @@ static class current_t { } return status_word; } + // cppcheck-suppress-end useStlAlgorithm bool has_format_1() const { return std::any_of( begin(), end(), @@ -1945,7 +1773,6 @@ static class current_t { const cbl_field_t * has_typedef( const cbl_field_t *field ) { auto found = typedefs.find(field); return found == typedefs.end()? NULL : *found; - return found == typedefs.end()? NULL : *found; } void udf_add( size_t isym ) { @@ -2001,12 +1828,12 @@ static class current_t { std::list<std::string>& debugging_declaratives(bool all) const { const char *para = programs.top().paragraph->name; - auto declaratives = debugging_clients.find(all? ":all:" : para); - if( declaratives == debugging_clients.end() ) { + auto client = debugging_clients.find(all? ":all:" : para); + if( client == debugging_clients.end() ) { static std::list<std::string> empty; return empty; } - return declaratives->second; + return client->second; } bool @@ -2029,19 +1856,6 @@ static class current_t { return programs.top().options.default_round = mode; } - cbl_call_convention_t - call_convention() { - return programs.empty()? cbl_call_cobol_e : programs.top().call_convention; - } - cbl_call_convention_t - call_convention( cbl_call_convention_t convention) { - if( programs.empty() ) { - return programs.pending_call_convention(convention); - } - auto& prog( programs.top() ); - return prog.call_convention = convention; - } - const char * locale() { return programs.empty()? NULL : programs.top().locale.os_name; @@ -2077,7 +1891,7 @@ static class current_t { const cbl_label_t *L; if( (L = symbol_program_add(parent, &label)) == NULL ) return false; - programs.push( symbol_index(symbol_elem_of(L))); + programs.push( prog_descr_t(symbol_index(symbol_elem_of(L))) ); programs.apply_pending(); bool fOK = symbol_at(programs.top().program_index) + 1 == symbols_end(); @@ -2101,10 +1915,6 @@ static class current_t { assert(!programs.empty()); return programs.top().program_index; } - size_t program_declaratives(void) const { - if( programs.empty() ) return 0; - return programs.top().declaratives_index; - } const cbl_label_t * program(void) { return programs.empty()? NULL : cbl_label_of(symbol_at(programs.top().program_index)); @@ -2118,12 +1928,16 @@ static class current_t { bool is_first_statement( const YYLTYPE& loc ) { if( ! in_declaratives && first_statement == 0 ) { - if( ! symbol_label_section_exists(program_index()) ) { - if( ! dialect_ibm() ) { - error_msg(loc, - "Per ISO a program with DECLARATIVES must begin with a SECTION, " - "requires -dialect ibm"); - } + auto eval = programs.top().declaratives_eval; + if( eval ) { + size_t ilabel = symbol_index(symbol_elem_of(eval)); + if( ! symbol_label_section_exists(ilabel) ) { + if( ! dialect_ibm() ) { + error_msg(loc, + "Per ISO a program with DECLARATIVES must begin with a SECTION, " + "requires %<-dialect ibm%>"); + } + } } first_statement = loc.first_line; return true; @@ -2139,13 +1953,14 @@ static class current_t { * ISO, in new_program. */ std::set<std::string> end_program() { + cbl_enabled_exceptions_t& enabled_exceptions( cdf_enabled_exceptions() ); if( enabled_exceptions.size() ) { declaratives_evaluate(); } assert(!programs.empty()); - procref_t *ref = ambiguous_reference(program_index()); + const procref_t *ref = ambiguous_reference(program_index()); std::set<std::string> externals = programs.top().external_targets(); /* @@ -2156,9 +1971,19 @@ static class current_t { * subprograms, and whether or not they are COMMON. PROGRAM may be * the caller, or a subprogram could call COMMON sibling. */ + + static std::unordered_set<size_t> callers_we_have_seen; if( programs.size() == 1 ) { if( yydebug ) parser_call_targets_dump(); for( size_t caller : symbol_program_programs() ) { + // We are running through the entire growing list of called programs + // at the point of each END PROGRAM. This confuses the name changing + // routines, so we use a std::set to avoid doing callers more than + // once. + if( callers_we_have_seen.find(caller) != callers_we_have_seen.end() ) + { + continue; + } const char *caller_name = cbl_label_of(symbol_at(caller))->name; for( auto callable : symbol_program_callables(caller) ) { auto called = cbl_label_of(symbol_at(callable)); @@ -2166,13 +1991,16 @@ static class current_t { called->mangled_name? called->mangled_name : called->name; size_t n = - parser_call_target_update(caller, called->name, mangled_name); + parser_call_target_update(caller, + called->name, + mangled_name); // Zero is not an error dbgmsg("updated " HOST_SIZE_T_PRINT_UNSIGNED " calls from #%-3" GCC_PRISZ "u (%s) s/%s/%s/", (fmt_size_t)n, (fmt_size_t)caller, caller_name, called->name, mangled_name); } + callers_we_have_seen.insert(caller); } if( yydebug ) parser_call_targets_dump(); } @@ -2214,24 +2042,25 @@ static class current_t { declaratives.runtime.dcl = parser_compile_dcls(declaratives.encode()); - size_t idcl = symbol_declaratives_add(program_index(), declaratives.as_list()); - programs.top().declaratives_index = idcl; - // Create section to evaluate declaratives. Given them unique names so // that we can figure out what is going on in a trace or looking at the // assembly language. - static int eval_count=1; - char eval[32]; - char lave[32]; + static int eval_count = 1; + char eval[32], lave[32]; + sprintf(eval, "_DECLARATIVES_EVAL%d", eval_count); - sprintf(lave, "_DECLARATIVES_LAVE%d", eval_count); - eval_count +=1 ; + sprintf(lave, "_DECLARATIVES_LAVE%d", eval_count++); struct cbl_label_t*& eval_label = programs.top().declaratives_eval; eval_label = label_add(LblSection, eval, yylineno); struct cbl_label_t * lave_label = label_add(LblSection, lave, yylineno); + ast_enter_section(eval_label); - declarative_runtime_match(cbl_field_of(symbol_at(idcl)), lave_label); + + declarative_runtime_match(declaratives.as_list(), lave_label); + + parser_label_label(lave_label); + return lave_label; } @@ -2261,11 +2090,10 @@ static class current_t { /* * END DECLARATIVES causes: - * 1. Add DECLARATIVES symbol, containing criteria blob. - * 2. Create section _DECLARATIVES_EVAL + * 1. Create section _DECLARATIVES_EVAL * and exit label _DECLARATIVES_LAVE - * 3. declarative_runtime_match generates runtime evaluation "ladder". - * 4. After a declarative is executed, control branches to the exit label. + * 2. declarative_runtime_match generates runtime evaluation "ladder". + * 3. After a declarative is executed, control branches to the exit label. * * After each verb, we call declaratives_evaluate, * which PERFORMs _DECLARATIVES_EVAL. @@ -2369,11 +2197,12 @@ void current_enabled_ecs( tree ena ) { static void add_debugging_declarative( const cbl_label_t * label ) { + // cppcheck-suppress [unreadVariable] obviously not true const char *section = current.declarative_section_name(); if( section ) { debugging_clients[label->name].push_back(section); } -}; +} cbl_options_t current_options() { return current.options_paragraph; @@ -2415,15 +2244,6 @@ current_rounded_mode( cbl_round_t rounded) { #endif static cbl_round_t current_rounded_mode( int token ); -cbl_call_convention_t -current_call_convention() { - return current.call_convention(); -} -cbl_call_convention_t -current_call_convention( cbl_call_convention_t convention) { - return current.call_convention(convention); -} - size_t program_level() { return current.program_level(); } static size_t constant_index( int token ); @@ -2443,10 +2263,14 @@ char * normalize_picture( char picture[] ); static inline cbl_field_t * -new_tempnumeric(void) { return new_temporary(FldNumericBin5); } +new_tempnumeric(const cbl_name_t name = nullptr) { + return new_temporary(FldNumericBin5, name); +} static inline cbl_field_t * -new_tempnumeric_float(void) { return new_temporary(FldFloat); } +new_tempnumeric_float(const cbl_name_t name = nullptr) { + return new_temporary(FldFloat, name); +} uint32_t type_capacity( enum cbl_field_type_t type, uint32_t digits ); @@ -2558,7 +2382,8 @@ is_callable( const cbl_field_t *field ) { case FldPointer: return true; } - cbl_internal_error( "%s:%d: invalid symbol_type_t %d", __func__, __LINE__, field->type ); + cbl_internal_error( "%s:%d: invalid %<symbol_type_t%> %d", + __func__, __LINE__, field->type ); return false; } @@ -2605,8 +2430,8 @@ intrinsic_call_1( cbl_field_t *output, int token, } static bool -intrinsic_call_2( cbl_field_t *tgt, int token, cbl_refer_t *r1, cbl_refer_t *r2 ) { - std::vector<cbl_refer_t> args { *r1, *r2 }; +intrinsic_call_2( cbl_field_t *tgt, int token, const cbl_refer_t *r1, cbl_refer_t *r2 ) { + std::vector<cbl_refer_t> args { *r1, r2? *r2 : cbl_refer_t() }; size_t n = intrinsic_invalid_parameter(token, args); if( n < args.size() ) { error_msg(args[n].loc, "invalid parameter '%s'", args[n].field->name); @@ -2683,18 +2508,14 @@ table_primary_index( cbl_field_t *table ) { NULL : cbl_field_of(symbol_at(table->occurs.indexes.fields[0])); } -static inline const cbl_refer_t // & // Removed the '&' to stop a weird compiler error +static inline const cbl_refer_t // return copy, not element reference invalid_key( const cbl_refer_t& ref ) { assert(ref.field); - - if( ref.nsubscript == 0 ) return ref; - - for( size_t i=0; i < ref.nsubscript; i++ ) { - if( ref.subscripts[i].field->parent != ref.field->parent ) { - return ref.subscripts[i]; - } - } - return NULL; + auto p = std::find_if( ref.subscripts.begin(), ref.subscripts.end(), + [parent = ref.field->parent]( const auto &sub ) { + return sub.field->parent == parent; + } ); + return p != ref.subscripts.end() ? *p : nullptr; } static inline symbol_elem_t * @@ -2896,17 +2717,6 @@ group_attr( const cbl_field_t * field ) { return p->attr; } -static struct symbol_elem_t * -field_of( const char F[], int L, const char name[] ) { - struct symbol_elem_t *e = symbol_field(PROGRAM, 0, name); - if( !e ) { - cbl_internal_error("%s:%d: no symbol '%s' found", F, L, name); - } - assert( procedure_div_e != current_division ); - return e; -} -#define field_of( F ) field_of(__func__, __LINE__, (F)) - static struct cbl_field_t * field_add( const YYLTYPE& loc, cbl_field_t *field ) { switch(current_data_section) { @@ -3142,6 +2952,17 @@ current_field(cbl_field_t * field = NULL) { return local; } +static void +set_real_from_capacity( const YYLTYPE& loc, + cbl_field_t *field, + REAL_VALUE_TYPE *r ) { + if( field == current_field() ) { + error_msg(loc, "cannot define %s via self-reference", field->name); + return; + } + field->data.set_real_from_capacity(r); +} + static struct cbl_special_name_t * special_of( const char F[], int L, const char name[] ) { struct symbol_elem_t *e = symbol_special(PROGRAM, name); @@ -3169,14 +2990,14 @@ cmd_or_env_special_of( std::string name ) { } static inline void -parser_add2( struct cbl_num_result_t& to, - struct cbl_refer_t from ) { +parser_add2( const cbl_num_result_t& to, + const cbl_refer_t& from ) { parser_add(to.refer, to.refer, from, to.rounded); } static inline void -parser_subtract2( struct cbl_num_result_t to, - struct cbl_refer_t from ) { +parser_subtract2( const cbl_num_result_t& to, + const cbl_refer_t& from ) { parser_subtract(to.refer, to.refer, from, to.rounded); } @@ -3199,6 +3020,11 @@ parser_move_carefully( const char */*F*/, int /*L*/, } } else { if( ! valid_move( tgt.field, src.field ) ) { + if( src.field->type == FldPointer && + tgt.field->type == FldPointer ) { + if( dialect_mf() || dialect_gnu() ) return true; + dialect_error(src.loc, "MOVE POINTER", "mf"); + } if( ! is_index ) { char ach[16]; char stype[32]; @@ -3224,7 +3050,6 @@ parser_move_carefully( const char */*F*/, int /*L*/, sprintf(ach, ".%d", tgt.field->data.rdigits); strcat(dtype, ach); } - error_msg(src.loc, "cannot MOVE '%s' (%s) to '%s' (%s)", name_of(src.field), stype, name_of(tgt.field), dtype); @@ -3260,11 +3085,11 @@ ast_set_pointers( const list<cbl_num_result_t>& tgts, cbl_refer_t src ) { void stringify( refer_collection_t *inputs, - cbl_refer_t into, cbl_refer_t pointer, + const cbl_refer_t& into, const cbl_refer_t& pointer, cbl_label_t *on_error = NULL, cbl_label_t *not_error = NULL); -void unstringify( cbl_refer_t& src, refer_list_t *delimited, +void unstringify( const cbl_refer_t& src, refer_list_t *delimited, unstring_into_t * into, cbl_label_t *on_error = NULL, cbl_label_t *not_error = NULL ); @@ -3289,6 +3114,7 @@ implicit_section() } static void +// cppcheck-suppress constParameterPointer ast_enter_exit_section( cbl_label_t * section ) { auto implicit = section? implicit_paragraph() : NULL; @@ -3368,7 +3194,7 @@ data_division_ready() { static bool -anybody_redefines(cbl_field_t *tree) +anybody_redefines( const cbl_field_t *tree ) { bool retval = false; while(tree) @@ -3378,7 +3204,8 @@ anybody_redefines(cbl_field_t *tree) retval = true; break; } - tree = parent_of(tree); + // cppcheck-suppress [unreadVariable] obviously not true + tree = parent_of(tree); } return retval; } @@ -3598,14 +3425,14 @@ file_section_parent_set( cbl_field_t *field ) { field->data.capacity); field->file = file_section_fd; - auto redefined = symbol_redefines(record_area); + const auto redefined = symbol_redefines(record_area); field->parent = redefined? record_area->parent : file->default_record; } return file_section_fd > 0; } void ast_call(const YYLTYPE& loc, cbl_refer_t name, - cbl_refer_t returning, + const cbl_refer_t& returning, size_t narg, cbl_ffi_arg_t args[], cbl_label_t *except, cbl_label_t *not_except, @@ -3666,18 +3493,18 @@ goodnight_gracie() { // false after USE statement, to enter Declarative with EC intact. static bool statement_cleanup = true; +static YYLTYPE current_location; static void statement_epilog( int token ); const char * keyword_str( int token ); -static YYLTYPE current_location; - const YYLTYPE& cobol_location() { return current_location; } -static inline YYLTYPE +static inline void location_set( const YYLTYPE& loc ) { - return current_location = loc; + current_location = loc; + gcc_location_set(loc); } static void statement_begin( const YYLTYPE& loc, int token ); diff --git a/gcc/cobol/parse_util.h b/gcc/cobol/parse_util.h index e504f46..20847e3 100644 --- a/gcc/cobol/parse_util.h +++ b/gcc/cobol/parse_util.h @@ -271,7 +271,7 @@ function_descr_t *function_descrs_end = function_descrs + COUNT_OF(function_desc class cname_cmp { const char *cname; public: - cname_cmp( const char *cname ) : cname(cname) {} + explicit cname_cmp( const char *cname ) : cname(cname) {} bool operator()( const function_descr_t& descr ) { return strlen(cname) == strlen(descr.cname) && @@ -283,6 +283,15 @@ class cname_cmp { } }; +static int +intrinsic_token_of( const char name[] ) { + auto pdescr = std::find_if( function_descrs, function_descrs_end, + [name]( const function_descr_t& descr ) { + return 0 == strcmp(name, descr.name); + } ); + return pdescr == function_descrs_end? 0 : pdescr->token; +} + /* * For variadic intrinsic functions, ensure all parameters are commensurate. * Return pointer in 1st inconsistent parameter type. @@ -293,8 +302,8 @@ intrinsic_inconsistent_parameter( size_t n, cbl_refer_t *args ) { class commensurate_type { cbl_refer_t first; public: - commensurate_type( const cbl_refer_t& first ) : first(first) {} - bool operator()( cbl_refer_t& arg ) const { + explicit commensurate_type( const cbl_refer_t& first ) : first(first) {} + bool operator()( const cbl_refer_t& arg ) const { return is_numeric(first.field) == is_numeric(arg.field); } }; @@ -348,7 +357,7 @@ intrinsic_invalid_parameter( int token, return token == descr.token; } ); if( p == function_descrs_end ) { - cbl_internal_error( "%s: intrinsic function %s not found", + cbl_internal_error( "%s: intrinsic function %qs not found", __func__, keyword_str(token) ); } diff --git a/gcc/cobol/scan.l b/gcc/cobol/scan.l index dfc0c30..ba4c044 100644 --- a/gcc/cobol/scan.l +++ b/gcc/cobol/scan.l @@ -79,14 +79,19 @@ nonseq (([''][[:alnum:]]+][''])|([""][[:alnum:]]+[""])) INTEGER 0*[1-9][[:digit:]]* INTEGERZ [[:digit:]]+ +NONWORD [^[:alnum:]$_-]+ + SPC [[:space:]]+ OSPC [[:space:]]* +BLANK [[:blank:]]+ +OBLANK [[:blank:]]* EOL \r?\n BLANK_EOL [[:blank:]]*{EOL} BLANK_OEOL [[:blank:]]*{EOL}? +PICTURE [^[:space:]]+ -DOTSEP [.][[:space:]] +DOTSEP [.]+[[:space:]] DOTEOL [[:blank:]]*[.]{BLANK_EOL} SKIP [[:blank:]]*SKIP[123][[:blank:]]*[.]?{BLANK_EOL} @@ -158,7 +163,7 @@ COMMA [,;][[:blank:]]* ISNT (IS{SPC})?NOT -COMMENTARY DATE-COMPILED|DATE-WRITTEN|INSTALLATION|SECURITY +COMMENTARY AUTHOR|DATE-COMPILED|DATE-WRITTEN|INSTALLATION|SECURITY SORT_MERGE SORT(-MERGE)? @@ -172,15 +177,15 @@ SIZE_ERROR (ON[[[:space:]]+)?SIZE[[:space:]]+ERROR VARTYPE NUMERIC|ALPHABETIC|ALPHABETIC_LOWER|ALPHABETIC_UPPER|DBCS|KANJI NAMTYP {NAME}|{VARTYPE} -NL [[:blank:]]*\r?\n[[:blank:]]* +NL [[:blank:]]*{EOL}[[:blank:]]* PUSH_FILE \f?[#]FILE{SPC}PUSH{SPC}[^\f]+\f POP_FILE \f?[#]FILE{SPC}POP\f -LINE_DIRECTIVE [#]line{SPC}[[:alnum:]]+{SPC}[""''].+\n +LINE_DIRECTIVE ^[#]line{SPC}[[:alnum:]]+{SPC}[""''].+\n %x procedure_div ident_state addr_of function classify %x program_id_state comment_entries -%x author_state date_state field_level field_state dot_state +%x date_state field_level field_state dot_state %x numeric_state name_state %x quoted1 quoted2 quoteq %x picture picture_count integer_count @@ -236,30 +241,23 @@ WORKING-STORAGE{SPC}SECTION { yy_push_state(field_state); return WORKING_STORAGE_SECT; } LOCAL-STORAGE{SPC}SECTION { - yy_push_state(field_state); - return LOCAL_STORAGE_SECT; } -WORKING-STORAGE { - return WORKING_STORAGE; } -LOCAL-STORAGE { - return LOCAL_STORAGE; } -SCREEN { - return SCREEN; } + yy_push_state(field_state); + return LOCAL_STORAGE_SECT; } +WORKING-STORAGE { return WORKING_STORAGE; } +LOCAL-STORAGE { return LOCAL_STORAGE; } +SCREEN { return SCREEN; } LINKAGE{SPC}SECTION { yy_push_state(field_state); return LINKAGE_SECT; } -FUNCTION-ID { yy_push_state(ident_state); - yy_push_state(program_id_state); - yy_push_state(name_state); return FUNCTION; } - -PROGRAM-ID { yy_push_state(ident_state); - yy_push_state(program_id_state); - yy_push_state(name_state); return PROGRAM_ID; } +FUNCTION-ID{OSPC}{DOTSEP}? { yy_push_state(ident_state); + yy_push_state(program_id_state); + yy_push_state(name_state); return FUNCTION; } -PROGRAM-ID/{DOTEOL} { yy_push_state(ident_state); - yy_push_state(name_state); - yy_push_state(dot_state); return PROGRAM_ID; } +PROGRAM-ID{OSPC}{DOTSEP}? { yy_push_state(ident_state); + yy_push_state(program_id_state); + yy_push_state(name_state); return PROGRAM_ID; } PROCEDURE{SPC}DIVISION { yy_push_state(procedure_div); return PROCEDURE_DIV; } @@ -270,29 +268,18 @@ PROCEDURE{SPC}DIVISION { yy_push_state(procedure_div); } <ident_state>{ + {BLANK_OEOL} + ID(ENTIFICATION)?{SPC}DIVISION { myless(0); yy_pop_state(); } + (ENVIRONMENT|DATA|PROCEDURE){SPC}DIVISION { + myless(0); yy_pop_state(); } + OPTIONS { myless(0); yy_pop_state(); } + AS{SPC}[""] { yy_push_state(quoted2); return AS; } AS{SPC}[''] { yy_push_state(quoted1); return AS; } IS { pop_return IS; } - OPTIONS { yy_pop_state(); myless(0); } - [[:blank:]]*(ENVIRONMENT|DATA|PROCEDURE)[[:blank:]]+DIVISION/.+\n { - yy_pop_state(); myless(0); } - [[:blank:]]*AUTHOR[[:blank:].]+{EOL}? { - // Might not have an EOL, but stop on one. - yy_push_state(author_state); } - - {DOTEOL} - {COMMENTARY} { BEGIN(comment_entries); } } -<author_state>{ - [[:blank:]]+ - ^{BLANK_EOL} - [^\r\n]+ { yy_pop_state(); - yylval.string = xstrdup(yytext); - } -} - <INITIAL>{ COBOL { return COBOL; } @@ -304,6 +291,15 @@ PROCEDURE{SPC}DIVISION { yy_push_state(procedure_div); yy_push_state(field_state); yy_set_bol(1); myless(0); } + + END{SPC}PROGRAM { yy_push_state(name_state); + return program_level() > 1? + END_SUBPROGRAM : END_PROGRAM; } + + END{SPC}FUNCTION { yy_push_state(name_state); + return program_level() > 1? + END_SUBPROGRAM /*invalid*/ : + END_FUNCTION; } } <INITIAL,procedure_div,cdf_state>{ @@ -326,6 +322,15 @@ CENTER { return typed_name(yytext); } + /* figurative constants that are otherwise matched as names */ + +ZEROE?S?/{OSPC}{DOTSEP} { return ZERO; } +SPACES?/{OSPC}{DOTSEP} { yylval.string = NULL; return SPACES; } +QUOTES?/{OSPC}{DOTSEP} { return QUOTES; } +NULLS?/{OSPC}{DOTSEP} { return NULLS; } +LOW-VALUES?/{OSPC}{DOTSEP} { return LOW_VALUES; } +HIGH-VALUES?/{OSPC}{DOTSEP} { return HIGH_VALUES; } + BINARY { return BINARY; } CLASSIFICATION { return CLASSIFICATION; } CYCLE { return CYCLE; } @@ -432,6 +437,11 @@ STDOUT { return STDOUT; } STDERR { return STDERR; } SYSERR { return STDERR; } +ARGUMENT-NUMBER { return ARGUMENT_NUMBER; } +ARGUMENT-VALUE { return ARGUMENT_VALUE; } +ENVIRONMENT-NAME { return ENVIRONMENT_NAME; } +ENVIRONMENT-VALUE { return ENVIRONMENT_VALUE; } + CANCEL { return CANCEL; } COMMIT { return COMMIT; } COMMON { return COMMON; } @@ -529,7 +539,7 @@ SECTION{SPC}[+-]?{INTEGERZ}/{OSPC}{DOTSEP} { auto eotext = yytext + yyleng; auto p = std::find_if(yytext, eotext, fisspace); p = std::find_if(p, eotext, nonspace); - yylval.string = p; + yylval.string = xstrdup(p); return SECTION; } @@ -856,8 +866,9 @@ ANUM { return ANUM; } ALTERNATE { return ALTERNATE; } ALTER { return ALTER; } ALSO { return ALSO; } -ALPHABET { return ALPHABET; } -ALPHABETIC { return ALPHABETIC; } + +ALPHABET { return ALPHABET; } +ALPHABETIC { return ALPHABETIC; } ALPHABETIC-LOWER { return ALPHABETIC_LOWER; } ALPHABETIC-UPPER { return ALPHABETIC_UPPER; } ALPHANUMERIC { return ALPHANUMERIC; } @@ -955,7 +966,9 @@ USE({SPC}FOR)? { return USE; } return NUMSTR; } - PIC(TURE)?({SPC}IS)?[[:space:]]{BLANK_OEOL} { + PIC(TURE)?({SPC}IS)?{SPC}{PICTURE} { + auto pos = validate_picture(); + myless(pos); yy_push_state(picture); return PIC; } ANY { return ANY; } @@ -980,7 +993,7 @@ USE({SPC}FOR)? { return USE; } BINARY-LONG { return bcomputable(FldNumericBin5, 4); } BINARY-DOUBLE { return bcomputable(FldNumericBin5, 8); } BINARY-LONG-LONG { if( ! dialect_mf() ) { - error_msg(yylloc, "%s requires -dialect mf", yytext); + dialect_error(yylloc, yytext, "mf"); } return bcomputable(FldNumericBin5, 8); } @@ -991,7 +1004,7 @@ USE({SPC}FOR)? { return USE; } FLOAT-BINARY-32 { return ucomputable(FldFloat, 4); } FLOAT-BINARY-64 { return ucomputable(FldFloat, 8); } FLOAT-BINARY-128 { return ucomputable(FldFloat, 16); } - FLOAT-DECIMAL-(16|34) { not_implemented("USAGE type: FLOAT_DECIMAL"); + FLOAT-DECIMAL-(16|34) { not_implemented("USAGE type: %<FLOAT_DECIMAL%>"); return FLOAT_DECIMAL; // causes syntax error } /* 21) The representation and length of a data item described with USAGE @@ -1017,7 +1030,7 @@ USE({SPC}FOR)? { return USE; } POINTER { yylval.field_attr = none_e; return POINTER; } PROCEDURE-POINTER { if( dialect_gcc() ) { - error_msg(yylloc, "%s requires -dialect ibm or mf", yytext); + dialect_error(yylloc, yytext, "ibm or mf"); } yylval.field_attr = prog_ptr_e; return POINTER; // return it anyway @@ -1137,7 +1150,7 @@ USE({SPC}FOR)? { return USE; } yy_push_state(hex_state); } N?X{nonseq} { dbgmsg("invalid hexadecimal value: %s", yytext); return NO_CONDITION; } - [[:blank:]]*\r?\n {} + [[:blank:]]*{EOL} {} WORKING-STORAGE{SPC}SECTION { return WORKING_STORAGE_SECT; } LOCAL-STORAGE{SPC}SECTION { return LOCAL_STORAGE_SECT; } @@ -1207,7 +1220,7 @@ USE({SPC}FOR)? { return USE; } {NP}V?/[,.]? { yylval.number = ndigit(yyleng); return picset(PIC_P); } {N9}*V/{N9}* { yylval.number = ndigit(yyleng - 1); return picset(NINEV); } {N9}/{N9}*[,.]? { yylval.number = ndigit(yyleng); return picset(NINES); } - P+/[,.]?\r?\n { yylval.number = yyleng; return picset(PIC_P); } + P+/[,.]?{EOL} { yylval.number = yyleng; return picset(PIC_P); } 1{1,31}/({COUNT}|[(]{NAME}[)]) { yy_push_state(picture_count); @@ -1306,7 +1319,7 @@ USE({SPC}FOR)? { return USE; } [""]{SPC}[&]{SPC}[""''] { if( yytext[yyleng - 1] == '\'' ) BEGIN(quoted1); } - [""]-{OSPC}(\r?\n{OSPC})+[""] /* continue ... */ + [""]-{OSPC}({EOL}{OSPC})+[""] /* continue ... */ [""] { char *s = xstrdup(tmpstring? tmpstring : "\0"); yylval.literal.set_data(strlen(s), s); @@ -1323,7 +1336,7 @@ USE({SPC}FOR)? { return USE; } ['']{SPC}[&]{SPC}[""''] { if( yytext[yyleng - 1] == '"' ) BEGIN(quoted2); } - ['']-{OSPC}(\r?\n{OSPC})+[''] /* continue ... */ + ['']-{OSPC}({EOL}{OSPC})+[''] /* continue ... */ [''] { char *s = xstrdup(tmpstring? tmpstring : "\0"); yylval.literal.set_data(strlen(s), s); @@ -1371,46 +1384,36 @@ USE({SPC}FOR)? { return USE; } } <program_id_state>{ - ^[[:blank:]]+ - ^{BLANK_EOL} + {BLANK_OEOL} (IS)?[[:space:]] + AS/{SPC} { myless(0); yy_pop_state(); } /* => ident_state */ - COMMON/[.]|{SPC}[[:alnum:].] { return COMMON; } - INITIAL/[.]|{SPC}[[:alnum:].] { return INITIAL_kw; } - RECURSIVE { return RECURSIVE; } - PROGRAM/[.]|{SPC}[[:alnum:].] { return PROGRAM_kw; } - - INITIAL { pop_return INITIAL_kw; } - COMMON { pop_return COMMON; } - PROGRAM { pop_return PROGRAM; } + INITIAL { return INITIAL_kw; } + COMMON { return COMMON; } + RECURSIVE { return RECURSIVE; } + PROGRAM { return PROGRAM_kw; } - AS/{SPC} { myless(0); yy_pop_state(); } /* => ident_state */ - [[:blank:]]*{DOTSEP}[[:blank:].]+{EOL} { pop_return '.'; } - {DOTEOL} { pop_return '.'; } + {DOTSEP} { pop_return '.'; } } -<name_state>{ - ^[[:blank:]]+ - ^{BLANK_EOL} - {NAME}/{OSPC}[.] { yy_pop_state(); - yylval.string = xstrdup(yytext); return NAME; } - {NAME} { yy_pop_state(); - yylval.string = xstrdup(yytext); return NAME; } +<name_state>{ /* Either pop from here, or let the quoted state pop */ + {BLANK_OEOL} + {NAME} { yy_pop_state(); + yylval.string = xstrdup(yytext); + return NAME; + } Z?[''] { yylval.literal.set_prefix(yytext, yyleng-1); - yy_push_state(quoted1); } + BEGIN(quoted1); } Z?[""] { yylval.literal.set_prefix(yytext, yyleng-1); - yy_push_state(quoted2); } + BEGIN(quoted2); } - [.]/[[:blank:]]+. { return *yytext; } - - [[:blank:]]*{DOTSEP}[[:blank:].]+{EOL} { - yy_pop_state(); myless(0); } - {DOTEOL} { yy_pop_state(); myless(0); } + . { myless(0); yy_pop_state(); + /* Should not happen for valid inputs. */ } } <dot_state>{ [[:blank:]]*[.][[:blank:].]+{EOL} { pop_return '.'; } - [[:blank:]]*[.] { pop_return '.'; } + [[:blank:]]*[.]+ { pop_return '.'; } } <date_state>{ @@ -1499,11 +1502,11 @@ USE({SPC}FOR)? { return USE; } {GREATER_THAN}{SPC}{OR_EQUAL}/[[:space:]] { return GE; } {GREATER_THAN} { return '>'; } - {ISNT}{SPC}">=" { return '<'; } - {ISNT}{SPC}">" { return LE; } - {ISNT}{SPC}"=" { return NE; } - {ISNT}{SPC}"<" { return GE; } - {ISNT}{SPC}"<=" { return '>'; } + {ISNT}{OSPC}">=" { verify_ws(yytext[yyleng - 3]); return '<'; } + {ISNT}{OSPC}">" { verify_ws(yytext[yyleng - 2]); return LE; } + {ISNT}{OSPC}"=" { verify_ws(yytext[yyleng - 2]); return NE; } + {ISNT}{OSPC}"<" { verify_ws(yytext[yyleng - 2]); return GE; } + {ISNT}{OSPC}"<=" { verify_ws(yytext[yyleng - 3]); return '>'; } {ISNT}{SPC}GREATER{SPC}(THAN)?{SPC}{OR_EQUAL}/[[:space:]] { return '<'; } {ISNT}{SPC}GREATER{SPC}(THAN)? { return LE; } @@ -1511,13 +1514,35 @@ USE({SPC}FOR)? { return USE; } {ISNT}{SPC}LESS{SPC}(THAN)? { return GE; } {ISNT}{SPC}LESS{SPC}(THAN)?{SPC}{OR_EQUAL}/[[:space:]] { return '>'; } - [*]{2}{SPC}[+] { return POW; } - "**" { return POW; } + [*]{2} { return POW; } + + /* + * "A boolean operator specifies the type of boolean operation to be performed + * on one or two operands, for a unary operator or binary operator, + * respectively." + * Binary boolean operators + * B-AND B-OR B-XOR + * Unary boolean operator + * B-NOT + * Boolean shift operators + * B-SHIFT-L B-SHIFT-LC B-SHIFT-R B-SHIFT-RC + */ + +B-AND +B-OR +B-XOR +B-NOT +B-SHIFT-L +B-SHIFT-LC +B-SHIFT-R +B-SHIFT-RC + } <procedure_div>{ (ID|IDENTIFICATION|ENVIRONMENT|DATA|PROCEDURE){SPC}DIVISION { - myless(0); yy_pop_state(); } + myless(0); BEGIN(INITIAL); } + PROGRAM-ID{OSPC}{DOTSEP} { myless(0); BEGIN(INITIAL); } EXIT{SPC}/(PROGRAM|SECTION|PARAGRAPH|PERFORM) { return EXIT; } @@ -1584,6 +1609,7 @@ USE({SPC}FOR)? { return USE; } DELIMITER { return DELIMITER; } ENVIRONMENT { return ENVIRONMENT; } + /* After name state, pop out of procedure_div state. */ END{SPC}PROGRAM { yy_push_state(name_state); return program_level() > 1? END_SUBPROGRAM : END_PROGRAM; } @@ -1610,24 +1636,10 @@ USE({SPC}FOR)? { return USE; } FUNCTION { yy_push_state(function); return FUNCTION; } - SECTION{OSPC}[.]{SPC}/USE[[:space:]] { yylval.string = NULL; return SECTION; } + SECTION{OSPC}[.]+{SPC}/USE[[:space:]] { yylval.string = NULL; return SECTION; } - {NAME}{OSPC}[.]({SPC}(EJECT|SKIP[123]))*{SPC}EXIT{OSPC}/{DOTSEP} { + [.]+({SPC}(EJECT|SKIP[123]))*{SPC}EXIT{OSPC}/{DOTSEP} { // EXIT format-1 is a "continue" statement - yylval.string = xstrdup(yytext); - auto p = strchr(yylval.string, '.'); - assert(p); - assert( ISSPACE(p[1]) ); - *p = '\0'; - while( p > yylval.string && ISSPACE(p[-1]) ) { - *--p = '\0'; - } - - int token; - if( 0 != (token = binary_integer_usage(yylval.string)) )return token; - if( 0 != (token = keyword_tok(yylval.string)) ) return token; - if( is_integer_token() ) return numstr_of(yylval.string); - return typed_name(yylval.string); } {NAME}/{OSPC}{DOTSEP} { assert(YY_START == procedure_div); @@ -1661,16 +1673,17 @@ USE({SPC}FOR)? { return USE; } p += 2; while( ISSPACE(*p) ) p++; cbl_name_t name2; - std::transform( p, p + sizeof(name2), name2, - []( char ch ) { - switch(ch) { - case '-': - case '_': return ch; - default: - if( ISALNUM(ch) ) return ch; - } - return '\0'; - } ); + const char *pend = p + sizeof(name2); + char *pout = name2; + while( p < pend ) { + char ch = *p++; + if( ISALNUM(ch) || ch == '-' || ch == '_' ) { + *pout++ = ch; + } else { + *pout++ = '\0'; + break; + } + } symbol_elem_t *e = symbol_file(PROGRAM, name2); /* * For NAME IN FILENAME, we want the parser to handle it. @@ -1795,126 +1808,128 @@ USE({SPC}FOR)? { return USE; } } <function>{ - - - ABS{OSPC}/[(]? { pop_return ABS; } - ACOS{OSPC}/[(]? { pop_return ACOS; } - ANNUITY{OSPC}/[(]? { pop_return ANNUITY; } - ASIN{OSPC}/[(]? { pop_return ASIN; } - ATAN{OSPC}/[(]? { pop_return ATAN; } - BASECONVERT{OSPC}/[(]? { pop_return BASECONVERT; } - BIT-OF{OSPC}/[(]? { pop_return BIT_OF; } - BIT-TO-CHAR{OSPC}/[(]? { pop_return BIT_TO_CHAR; } - BOOLEAN-OF-INTEGER{OSPC}/[(]? { pop_return BOOLEAN_OF_INTEGER; } - BYTE-LENGTH{OSPC}/[(]? { pop_return BYTE_LENGTH; } - CHAR-NATIONAL{OSPC}/[(]? { pop_return CHAR_NATIONAL; } - CHAR{OSPC}/[(]? { pop_return CHAR; } - COMBINED-DATETIME{OSPC}/[(]? { pop_return COMBINED_DATETIME; } - CONCAT{OSPC}/[(]? { pop_return CONCAT; } - CONTENT-LENGTH{OSPC}/[(]? { pop_return NO_CONDITION; /* GNU only*/ } - CONTENT-OF{OSPC}/[(]? { pop_return NO_CONDITION; /* GNU only*/ } - CONVERT{OSPC}/[(]? { pop_return CONVERT; } - COS{OSPC}/[(]? { pop_return COS; } - CURRENCY-SYBOL{OSPC}/[(]? { pop_return NO_CONDITION; /* GNU only*/ } - CURRENT-DATE{OSPC}/[(]? { pop_return CURRENT_DATE; } - DATE-OF-INTEGER{OSPC}/[(]? { pop_return DATE_OF_INTEGER; } - DATE-TO-YYYYMMDD{OSPC}/[(]? { pop_return DATE_TO_YYYYMMDD; } - DAY-OF-INTEGER{OSPC}/[(]? { pop_return DAY_OF_INTEGER; } - DAY-TO-YYYYDDD{OSPC}/[(]? { pop_return DAY_TO_YYYYDDD; } - DISPLAY-OF{OSPC}/[(]? { pop_return DISPLAY_OF; } - E{OSPC}/[(]? { pop_return E; } - - EXCEPTION-FILE-N{OSPC}/[(]? { pop_return EXCEPTION_FILE_N; } - EXCEPTION-FILE{OSPC}/[(]? { pop_return EXCEPTION_FILE; } - EXCEPTION-LOCATION-N{OSPC}/[(]? { pop_return EXCEPTION_LOCATION_N; } - EXCEPTION-LOCATION{OSPC}/[(]? { pop_return EXCEPTION_LOCATION; } - EXCEPTION-STATEMENT{OSPC}/[(]? { pop_return EXCEPTION_STATEMENT; } - EXCEPTION-STATUS{OSPC}/[(]? { pop_return EXCEPTION_STATUS; } - - EXP{OSPC}/[(]? { pop_return EXP; } - EXP10{OSPC}/[(]? { pop_return EXP10; } - FACTORIAL{OSPC}/[(]? { pop_return FACTORIAL; } - FIND-STRING{OSPC}/[(]? { pop_return FIND_STRING; } - - FORMATTED-CURRENT-DATE{OSPC}/[(]? { BEGIN(datetime_fmt); return FORMATTED_CURRENT_DATE; } - FORMATTED-DATE{OSPC}/[(]? { BEGIN(datetime_fmt); return FORMATTED_DATE; } - FORMATTED-DATETIME{OSPC}/[(]? { BEGIN(datetime_fmt); return FORMATTED_DATETIME; } - FORMATTED-TIME{OSPC}/[(]? { BEGIN(datetime_fmt); return FORMATTED_TIME; } - FRACTION-PART{OSPC}/[(]? { pop_return FRACTION_PART; } - - HEX-OF{OSPC}/[(]? { pop_return HEX_OF; } - HEX-TO-CHAR{OSPC}/[(]? { pop_return HEX_TO_CHAR; } - HIGHEST-ALGEBRAIC{OSPC}/[(]? { pop_return HIGHEST_ALGEBRAIC; } - - INTEGER{OSPC}/[(]? { pop_return INTEGER; } - INTEGER-OF-BOOLEAN{OSPC}/[(]? { pop_return INTEGER_OF_BOOLEAN; } - INTEGER-OF-DATE{OSPC}/[(]? { pop_return INTEGER_OF_DATE; } - INTEGER-OF-DAY{OSPC}/[(]? { pop_return INTEGER_OF_DAY; } - INTEGER-OF-FORMATTED-DATE{OSPC}/[(]? { BEGIN(datetime_fmt); return INTEGER_OF_FORMATTED_DATE; } - INTEGER-PART{OSPC}/[(]? { pop_return INTEGER_PART; } - LENGTH{OSPC}/[(]? { pop_return LENGTH; } - LOCALE-COMPARE{OSPC}/[(]? { pop_return LOCALE_COMPARE; } - LOCALE-DATE{OSPC}/[(]? { pop_return LOCALE_DATE; } - LOCALE-TIME{OSPC}/[(]? { pop_return LOCALE_TIME; } - LOCALE-TIME-FROM-SECONDS{OSPC}/[(]? { pop_return LOCALE_TIME_FROM_SECONDS; } - LOG{OSPC}/[(]? { pop_return LOG; } - LOG10{OSPC}/[(]? { pop_return LOG10; } - LOWER-CASE{OSPC}/[(]? { pop_return LOWER_CASE; } - LOWEST-ALGEBRAIC{OSPC}/[(]? { pop_return LOWEST_ALGEBRAIC; } - MAX{OSPC}/[(]? { pop_return MAXX; } - MEAN{OSPC}/[(]? { pop_return MEAN; } - MEDIAN{OSPC}/[(]? { pop_return MEDIAN; } - MIDRANGE{OSPC}/[(]? { pop_return MIDRANGE; } - MIN{OSPC}/[(]? { pop_return MINN; } - MOD{OSPC}/[(]? { pop_return MOD; } - MODULE-NAME{OSPC}/[(]? { pop_return MODULE_NAME; } - NATIONAL-OF{OSPC}/[(]? { pop_return NATIONAL_OF; } - NUMVAL{OSPC}/[(]? { pop_return NUMVAL; } - NUMVAL-C{OSPC}/[(]? { pop_return NUMVAL_C; } - NUMVAL-F{OSPC}/[(]? { pop_return NUMVAL_F; } - ORD{OSPC}/[(]? { pop_return ORD; } - ORD-MAX{OSPC}/[(]? { pop_return ORD_MAX; } - ORD-MIN{OSPC}/[(]? { pop_return ORD_MIN; } - PI{OSPC}/[(]? { pop_return PI; } - PRESENT-VALUE{OSPC}/[(]? { pop_return PRESENT_VALUE; } + ABS/{NONWORD} { pop_return ABS; } + ACOS/{NONWORD} { pop_return ACOS; } + ANNUITY/{NONWORD} { pop_return ANNUITY; } + ASIN/{NONWORD} { pop_return ASIN; } + ATAN/{NONWORD} { pop_return ATAN; } + BASECONVERT/{NONWORD} { pop_return BASECONVERT; } + BIT-OF/{NONWORD} { pop_return BIT_OF; } + BIT-TO-CHAR/{NONWORD} { pop_return BIT_TO_CHAR; } + BOOLEAN-OF-INTEGER/{NONWORD} { pop_return BOOLEAN_OF_INTEGER; } + BYTE-LENGTH/{NONWORD} { pop_return BYTE_LENGTH; } + CHAR-NATIONAL/{NONWORD} { pop_return CHAR_NATIONAL; } + CHAR/{NONWORD} { pop_return CHAR; } + COMBINED-DATETIME/{NONWORD} { pop_return COMBINED_DATETIME; } + CONCAT/{NONWORD} { pop_return CONCAT; } + CONTENT-LENGTH/{NONWORD} { pop_return NO_CONDITION; /* GNU only*/ } + CONTENT-OF/{NONWORD} { pop_return NO_CONDITION; /* GNU only*/ } + CONVERT/{NONWORD} { pop_return CONVERT; } + COS/{NONWORD} { pop_return COS; } + CURRENCY-SYBOL/{NONWORD} { pop_return NO_CONDITION; /* GNU only*/ } + CURRENT-DATE/{NONWORD} { pop_return CURRENT_DATE; } + DATE-OF-INTEGER/{NONWORD} { pop_return DATE_OF_INTEGER; } + DATE-TO-YYYYMMDD/{NONWORD} { pop_return DATE_TO_YYYYMMDD; } + DAY-OF-INTEGER/{NONWORD} { pop_return DAY_OF_INTEGER; } + DAY-TO-YYYYDDD/{NONWORD} { pop_return DAY_TO_YYYYDDD; } + DISPLAY-OF/{NONWORD} { pop_return DISPLAY_OF; } + E/{NONWORD} { pop_return E; } + + EXCEPTION-FILE-N/{NONWORD} { pop_return EXCEPTION_FILE_N; } + EXCEPTION-FILE/{NONWORD} { pop_return EXCEPTION_FILE; } + EXCEPTION-LOCATION-N/{NONWORD} { pop_return EXCEPTION_LOCATION_N; } + EXCEPTION-LOCATION/{NONWORD} { pop_return EXCEPTION_LOCATION; } + EXCEPTION-STATEMENT/{NONWORD} { pop_return EXCEPTION_STATEMENT; } + EXCEPTION-STATUS/{NONWORD} { pop_return EXCEPTION_STATUS; } + + EXP/{NONWORD} { pop_return EXP; } + EXP10/{NONWORD} { pop_return EXP10; } + FACTORIAL/{NONWORD} { pop_return FACTORIAL; } + FIND-STRING/{NONWORD} { pop_return FIND_STRING; } + + FORMATTED-CURRENT-DATE/{NONWORD} { BEGIN(datetime_fmt); + return FORMATTED_CURRENT_DATE; } + FORMATTED-DATE/{NONWORD} { BEGIN(datetime_fmt); return FORMATTED_DATE; } + FORMATTED-DATETIME/{NONWORD} { BEGIN(datetime_fmt); return FORMATTED_DATETIME; } + FORMATTED-TIME/{NONWORD} { BEGIN(datetime_fmt); return FORMATTED_TIME; } + FRACTION-PART/{NONWORD} { pop_return FRACTION_PART; } + + HEX-OF/{NONWORD} { pop_return HEX_OF; } + HEX-TO-CHAR/{NONWORD} { pop_return HEX_TO_CHAR; } + HIGHEST-ALGEBRAIC/{NONWORD} { pop_return HIGHEST_ALGEBRAIC; } + + INTEGER/{NONWORD} { pop_return INTEGER; } + INTEGER-OF-BOOLEAN/{NONWORD} { pop_return INTEGER_OF_BOOLEAN; } + INTEGER-OF-DATE/{NONWORD} { pop_return INTEGER_OF_DATE; } + INTEGER-OF-DAY/{NONWORD} { pop_return INTEGER_OF_DAY; } + INTEGER-OF-FORMATTED-DATE/{NONWORD} { BEGIN(datetime_fmt); + return INTEGER_OF_FORMATTED_DATE; } + INTEGER-PART/{NONWORD} { pop_return INTEGER_PART; } + LENGTH/{NONWORD} { pop_return LENGTH; } + LOCALE-COMPARE/{NONWORD} { pop_return LOCALE_COMPARE; } + LOCALE-DATE/{NONWORD} { pop_return LOCALE_DATE; } + LOCALE-TIME/{NONWORD} { pop_return LOCALE_TIME; } + LOCALE-TIME-FROM-SECONDS/{NONWORD} { pop_return LOCALE_TIME_FROM_SECONDS; } + LOG/{NONWORD} { pop_return LOG; } + LOG10/{NONWORD} { pop_return LOG10; } + LOWER-CASE/{NONWORD} { pop_return LOWER_CASE; } + LOWEST-ALGEBRAIC/{NONWORD} { pop_return LOWEST_ALGEBRAIC; } + MAX/{NONWORD} { pop_return MAXX; } + MEAN/{NONWORD} { pop_return MEAN; } + MEDIAN/{NONWORD} { pop_return MEDIAN; } + MIDRANGE/{NONWORD} { pop_return MIDRANGE; } + MIN/{NONWORD} { pop_return MINN; } + MOD/{NONWORD} { pop_return MOD; } + MODULE-NAME/{NONWORD} { pop_return MODULE_NAME; } + NATIONAL-OF/{NONWORD} { pop_return NATIONAL_OF; } + NUMVAL/{NONWORD} { pop_return NUMVAL; } + NUMVAL-C/{NONWORD} { pop_return NUMVAL_C; } + NUMVAL-F/{NONWORD} { pop_return NUMVAL_F; } + ORD/{NONWORD} { pop_return ORD; } + ORD-MAX/{NONWORD} { pop_return ORD_MAX; } + ORD-MIN/{NONWORD} { pop_return ORD_MIN; } + PI/{NONWORD} { pop_return PI; } + PRESENT-VALUE/{NONWORD} { pop_return PRESENT_VALUE; } RANDOM{OSPC}{PARENS} { pop_return RANDOM; } RANDOM{OSPC}[(] { pop_return RANDOM_SEED; } RANDOM { pop_return RANDOM; } - RANGE{OSPC}/[(]? { pop_return RANGE; } - REM{OSPC}/[(]? { pop_return REM; } - REVERSE{OSPC}/[(]? { pop_return REVERSE; } - SECONDS-FROM-FORMATTED-TIME{OSPC}/[(]? { BEGIN(datetime_fmt); + RANGE/{NONWORD} { pop_return RANGE; } + REM/{NONWORD} { pop_return REM; } + REVERSE/{NONWORD} { pop_return REVERSE; } + SECONDS-FROM-FORMATTED-TIME/{NONWORD} { BEGIN(datetime_fmt); return SECONDS_FROM_FORMATTED_TIME; } - SECONDS-PAST-MIDNIGHT{OSPC}/[(]? { pop_return SECONDS_PAST_MIDNIGHT; } - SIGN{OSPC}/[(]? { pop_return SIGN; } - SIN{OSPC}/[(]? { pop_return SIN; } - SMALLEST-ALGEBRAIC{OSPC}/[(]? { pop_return SMALLEST_ALGEBRAIC; } - SQRT{OSPC}/[(]? { pop_return SQRT; } - STANDARD-COMPARE{OSPC}/[(]? { pop_return STANDARD_COMPARE; } - STANDARD-DEVIATION{OSPC}/[(]? { pop_return STANDARD_DEVIATION; } - SUBSTITUTE{OSPC}/[(]? { pop_return SUBSTITUTE; } - SUM{OSPC}/[(]? { pop_return SUM; } - TAN{OSPC}/[(]? { pop_return TAN; } - TEST-DATE-YYYYMMDD{OSPC}/[(]? { pop_return TEST_DATE_YYYYMMDD; } - TEST-DAY-YYYYDDD{OSPC}/[(]? { pop_return TEST_DAY_YYYYDDD; } - TEST-FORMATTED-DATETIME{OSPC}/[(]? { BEGIN(datetime_fmt); return TEST_FORMATTED_DATETIME; } - TEST-NUMVAL{OSPC}/[(]? { pop_return TEST_NUMVAL; } - TEST-NUMVAL-C{OSPC}/[(]? { pop_return TEST_NUMVAL_C; } - TEST-NUMVAL-F{OSPC}/[(]? { pop_return TEST_NUMVAL_F; } - TRIM{OSPC}/[(]? { pop_return TRIM; } - ULENGTH{OSPC}/[(]? { pop_return ULENGTH; } - UPOS{OSPC}/[(]? { pop_return UPOS; } - UPPER-CASE{OSPC}/[(]? { pop_return UPPER_CASE; } - USUBSTR{OSPC}/[(]? { pop_return USUBSTR; } - USUPPLEMENTARY{OSPC}/[(]? { pop_return USUPPLEMENTARY; } - UUID4{OSPC}/[(]? { pop_return UUID4; } - UVALID{OSPC}/[(]? { pop_return UVALID; } - UWIDTH{OSPC}/[(]? { pop_return UWIDTH; } - VARIANCE{OSPC}/[(]? { pop_return VARIANCE; } - WHEN-COMPILED{OSPC}/[(]? { pop_return WHEN_COMPILED; } - YEAR-TO-YYYY{OSPC}/[(]? { pop_return YEAR_TO_YYYY; } + SECONDS-PAST-MIDNIGHT/{NONWORD} { pop_return SECONDS_PAST_MIDNIGHT; } + SIGN/{NONWORD} { pop_return SIGN; } + SIN/{NONWORD} { pop_return SIN; } + SMALLEST-ALGEBRAIC/{NONWORD} { pop_return SMALLEST_ALGEBRAIC; } + SQRT/{NONWORD} { pop_return SQRT; } + STANDARD-COMPARE/{NONWORD} { pop_return STANDARD_COMPARE; } + STANDARD-DEVIATION/{NONWORD} { pop_return STANDARD_DEVIATION; } + SUBSTITUTE/{NONWORD} { pop_return SUBSTITUTE; } + SUM/{NONWORD} { pop_return SUM; } + TAN/{NONWORD} { pop_return TAN; } + TEST-DATE-YYYYMMDD/{NONWORD} { pop_return TEST_DATE_YYYYMMDD; } + TEST-DAY-YYYYDDD/{NONWORD} { pop_return TEST_DAY_YYYYDDD; } + TEST-FORMATTED-DATETIME/{NONWORD} { BEGIN(datetime_fmt); return TEST_FORMATTED_DATETIME; } + TEST-NUMVAL/{NONWORD} { pop_return TEST_NUMVAL; } + TEST-NUMVAL-C/{NONWORD} { pop_return TEST_NUMVAL_C; } + TEST-NUMVAL-F/{NONWORD} { pop_return TEST_NUMVAL_F; } + TRIM/{NONWORD} { pop_return TRIM; } + ULENGTH/{NONWORD} { pop_return ULENGTH; } + UPOS/{NONWORD} { pop_return UPOS; } + UPPER-CASE/{NONWORD} { pop_return UPPER_CASE; } + USUBSTR/{NONWORD} { pop_return USUBSTR; } + USUPPLEMENTARY/{NONWORD} { pop_return USUPPLEMENTARY; } + UUID4/{NONWORD} { pop_return UUID4; } + UVALID/{NONWORD} { pop_return UVALID; } + UWIDTH/{NONWORD} { pop_return UWIDTH; } + VARIANCE/{NONWORD} { pop_return VARIANCE; } + WHEN-COMPILED/{NONWORD} { pop_return WHEN_COMPILED; } + YEAR-TO-YYYY/{NONWORD} { pop_return YEAR_TO_YYYY; } + + /* Matches above include NONWORD because the NAME tests below are otherwise longer, */ {NAME}{OSPC}/[(] { /* If /{OSPC}, "dangerous trailing context" "*/ auto name = null_trim(xstrdup(yytext)); @@ -2009,7 +2024,7 @@ BASIS { yy_push_state(basis); return BASIS; } } return token; } - [.][[:blank:].]+ { return '.'; } + [.]+[[:blank:].]+ { return '.'; } } <exception>{ @@ -2029,7 +2044,7 @@ BASIS { yy_push_state(basis); return BASIS; } return symbol_file(PROGRAM, yytext)? FILENAME : NAME; } [[:blank:]]+ - \r?\n { yy_pop_state(); } + {EOL} { yy_pop_state(); } } <raising>{ @@ -2050,49 +2065,62 @@ BASIS { yy_push_state(basis); return BASIS; } if( include_debug() ) myless(7); } } - ^[ ]*>>{OSPC}IF { yy_push_state(cdf_state); return CDF_IF; } - ^[ ]*>>{OSPC}ELSE { return CDF_ELSE; } - ^[ ]*>>{OSPC}END-IF { return CDF_END_IF; } + ^[ ]*>>{OBLANK}IF { yy_push_state(cdf_state); return CDF_IF; } + ^[ ]*>>{OBLANK}ELSE { return CDF_ELSE; } + ^[ ]*>>{OBLANK}END-IF { return CDF_END_IF; } - ^[ ]*[$]{OSPC}IF { if( ! dialect_mf() ) { + ^[ ]*[$]{OBLANK}IF { if( ! dialect_mf() ) { dialect_error(yylloc, yytext, "mf"); } yy_push_state(cdf_state); return CDF_IF; } - ^[ ]*[$]{OSPC}ELSE { if( ! dialect_mf() ) { + ^[ ]*[$]{OBLANK}ELSE { if( ! dialect_mf() ) { dialect_error(yylloc, yytext, "mf"); } return CDF_ELSE; } - ^[ ]*[$]{OSPC}END { if( ! dialect_mf() ) { + ^[ ]*[$]{OBLANK}END { if( ! dialect_mf() ) { dialect_error(yylloc, yytext, "mf"); } return CDF_END_IF; } - ^[ ]*[$]{OSPC}SET({SPC}CONSTANT)? { + ^[ ]*[$]{OBLANK}SET({SPC}CONSTANT)? { if( ! dialect_mf() ) dialect_error(yylloc, yytext, "mf"); yy_push_state(cdf_state); return CDF_DEFINE; } - ^[ ]*>>{OSPC}EVALUATE { return CDF_EVALUATE; } - ^[ ]*>>{OSPC}WHEN { return CDF_WHEN; } - ^[ ]*>>{OSPC}END-EVALUATE { return CDF_END_EVALUATE; } + ^[ ]*>>{OBLANK}EVALUATE { return CDF_EVALUATE; } + ^[ ]*>>{OBLANK}WHEN { return CDF_WHEN; } + ^[ ]*>>{OBLANK}END-EVALUATE { return CDF_END_EVALUATE; } - ^[ ]*>>{OSPC}CALL-CONVENTION{SPC}C { return CALL_VERBATIM; } - ^[ ]*>>{OSPC}CALL-CONVENTION{SPC}COBOL { return CALL_COBOL; } - ^[ ]*>>{OSPC}CALL-CONVENTION{SPC}VERBATIM { return CALL_VERBATIM; } + ^[ ]*>>{OBLANK}CALL-CONVENTION{BLANK}C { return CALL_VERBATIM; } + ^[ ]*>>{OBLANK}CALL-CONVENTION{BLANK}COBOL { return CALL_COBOL; } + ^[ ]*>>{OBLANK}CALL-CONVENTION{BLANK}VERBATIM { return CALL_VERBATIM; } - ^[ ]*>>{OSPC}DEFINE { yy_push_state(cdf_state); return CDF_DEFINE; } - ^[ ]*>>{OSPC}DISPLAY { return CDF_DISPLAY; } - ^[ ]*>>{OSPC}TURN { yy_push_state(exception); return TURN; } - ^[ ]*>>{OSPC}COBOL-WORDS { yy_push_state(cobol_words); return COBOL_WORDS; } + ^[ ]*>>{OBLANK}DEFINE { yy_push_state(cdf_state); return CDF_DEFINE; } + ^[ ]*>>{OBLANK}DISPLAY { return CDF_DISPLAY; } + ^[ ]*>>{OBLANK}TURN { yy_push_state(exception); return TURN; } + ^[ ]*>>{OBLANK}COBOL-WORDS { yy_push_state(cobol_words); return COBOL_WORDS; } - ^[ ]*>>{OSPC}{NAME} { + ^[ ]*>>{OBLANK}SOURCE{BLANK}FORMAT { return SOURCE_FORMAT; } + + ^[ ]*>>{OBLANK}PUSH { return CDF_PUSH; } + ^[ ]*>>{OBLANK}POP { return CDF_POP; } + + ^[ ]*>>{OBLANK}{NAME} { error_msg(yylloc, "unknown CDF token: %s", yytext); } + OTHER { return OTHER; } OVERRIDE { return OVERRIDE; } PARAMETER { return PARAMETER_kw; } THRU { return THRU; } TRUE { return TRUE_kw; } + + ALL { return ALL; } + CALL-CONVENTION { return CALL_CONVENTION; } + COBOL-WORDS { return COBOL_WORDS; } + DEFINE { return CDF_DEFINE; } + SOURCE{BLANK}FORMAT { return SOURCE_FORMAT; } + } <cobol_words>{ @@ -2107,39 +2135,45 @@ BASIS { yy_push_state(basis); return BASIS; } } <*>{ - {PUSH_FILE} { - yy_set_bol(true); - auto top_file = cobol_lineno_save(); - if( top_file ) { - if( yy_flex_debug ) dbgmsg(" saving line %4d of %s", - yylineno, top_file); - } - // "\f#file push <name>": name starts at offset 13. - char *filename = xstrdup(yytext); - filename[yyleng - 1] = '\0'; // kill the trailing formfeed - filename += 12; - if( yytext[0] != '\f' ) { - dbgmsg("logic warning: filename was adjusted to %s", --filename); + {PUSH_FILE} { + yy_set_bol(true); + auto top_file = cobol_lineno(yylineno); + if( top_file ) { + if( yy_flex_debug ) dbgmsg(" saving line %4d of %s", + yylineno, top_file); + } + // "\f#file push <name>": name starts at offset 13. + char *filename = xstrdup(yytext); + filename[yyleng - 1] = '\0'; // kill the trailing formfeed + filename += 12; + if( yytext[0] != '\f' ) { + dbgmsg("logic warning: filename was adjusted to %s", + --filename); + } + input_file_status.enter(filename); + yylineno = 1; + reset_location(); + } + + {POP_FILE} { + yy_set_bol(true); + input_file_status.leave(); + yylineno = cobol_lineno(); } - input_file_status.enter(filename); - } - - {POP_FILE} { - yy_set_bol(true); - input_file_status.leave(); - } - {LINE_DIRECTIVE} { cobol_fileline_set(yytext); } + {LINE_DIRECTIVE} { + yylineno = cobol_fileline_set(yytext); + reset_location(); + } } <*>OR { return OR; } <*>AND { return AND; } -<*>{DOTSEP}[[:blank:].]+$ { return '.'; } -<*>[*/+-]{SPC}[+] { return *yytext; } +<*>{DOTSEP} { return '.'; } <*>[().=*/+&-] { return *yytext; } <*>[[:blank:]]+ -<*>\r?\n +<*>{EOL} <*>{ {COMMA} @@ -2150,48 +2184,48 @@ BASIS { yy_push_state(basis); return BASIS; } <*>{ ACCEPT { return ACCEPT; } ACCESS { return ACCESS; } - ADD { return ADD; } + ADD { return ADD; } ADDRESS { return ADDRESS; } ADVANCING { return ADVANCING; } - AFTER { return AFTER; } - ALL { return ALL; } + AFTER { return AFTER; } + ALL { return ALL; } ALLOCATE { return ALLOCATE; } ALPHABET { return ALPHABET; } ALPHABETIC { return ALPHABETIC; } ALPHABETIC-LOWER { return ALPHABETIC_LOWER; } ALPHABETIC-UPPER { return ALPHABETIC_UPPER; } - ALPHANUMERIC { return ALPHANUMERIC; } + ALPHANUMERIC { return ALPHANUMERIC; } ALPHANUMERIC-EDITED { return ALPHANUMERIC_EDITED; } - ALSO { return ALSO; } + ALSO { return ALSO; } ALTERNATE { return ALTERNATE; } - AND { return AND; } - ANY { return ANY; } + AND { return AND; } + ANY { return ANY; } ANYCASE { return ANYCASE; } - ARE { return ARE; } - AREA { return AREA; } - AREAS { return AREAS; } - AS { return AS; } + ARE { return ARE; } + AREA { return AREA; } + AREAS { return AREAS; } + AS { return AS; } ASCENDING { return ASCENDING; } - ASSIGN { return ASSIGN; } - AT { return AT; } - BASED { return BASED; } + ASSIGN { return ASSIGN; } + AT { return AT; } + BASED { return BASED; } BEFORE { return BEFORE; } BINARY { return BINARY; } - BIT { return BIT; } - BLANK { return BLANK; } - BLOCK { return BLOCK_kw; } + BIT { return BIT; } + BLANK { return BLANK; } + BLOCK { return BLOCK_kw; } BOTTOM { return BOTTOM; } - BY { return BY; } - CALL { return CALL; } + BY { return BY; } + CALL { return CALL; } CANCEL { return CANCEL; } - CF { return CF; } - CH { return CH; } + CF { return CF; } + CH { return CH; } CHARACTER { return CHARACTER; } CHARACTERS { return CHARACTERS; } - CLASS { return CLASS; } - CLOSE { return CLOSE; } - CODE { return CODE; } - COMMA { return COMMA; } + CLASS { return CLASS; } + CLOSE { return CLOSE; } + CODE { return CODE; } + COMMA { return COMMA; } COMMIT { return COMMIT; } COMMON { return COMMON; } CONDITION { return CONDITION; } @@ -2202,14 +2236,14 @@ BASIS { yy_push_state(basis); return BASIS; } CONTROL { return CONTROL; } CONTROLS { return CONTROLS; } CONVERTING { return CONVERTING; } - COPY { return COPY; } - COUNT { return COUNT; } + COPY { return COPY; } + COUNT { return COUNT; } CURRENCY { return CURRENCY; } - DATA { return DATA; } - DATE { return DATE; } - DAY { return DAY; } + DATA { return DATA; } + DATE { return DATE; } + DAY { return DAY; } DAY-OF-WEEK { return DAY_OF_WEEK; } - DE { return DE; } + DE { return DE; } DECIMAL-POINT { return DECIMAL_POINT; } DECLARATIVES { return DECLARATIVES; } DEFAULT { return DEFAULT; } @@ -2221,12 +2255,12 @@ BASIS { yy_push_state(basis); return BASIS; } DETAIL { return DETAIL; } DISPLAY { return DISPLAY; } DIVIDE { return DIVIDE; } - DOWN { return DOWN; } + DOWN { return DOWN; } DUPLICATES { return DUPLICATES; } DYNAMIC { return DYNAMIC; } - EC { return EC; } - ELSE { return ELSE; } - END { return END; } + EC { return EC; } + ELSE { return ELSE; } + END { return END; } END-ACCEPT { return END_ACCEPT; } END-ADD { return END_ADD; } END-CALL { return END_CALL; } @@ -2244,117 +2278,116 @@ BASIS { yy_push_state(basis); return BASIS; } END-SUBTRACT { return END_SUBTRACT; } END-WRITE { return END_WRITE; } ENVIRONMENT { return ENVIRONMENT; } - EQUAL { return EQUAL; } - ERROR { return ERROR; } + EQUAL { return EQUAL; } + ERROR { return ERROR; } EVALUATE { return EVALUATE; } EXCEPTION { return EXCEPTION; } - EXIT { return EXIT; } + EXIT { return EXIT; } EXTEND { return EXTEND; } EXTERNAL { return EXTERNAL; } - FD { return FD; } - FINAL { return FINAL; } + FD { return FD; } + FINAL { return FINAL; } FINALLY { return FINALLY; } - FIRST { return FIRST; } + FIRST { return FIRST; } FOOTING { return FOOTING; } - FOR { return FOR; } - FREE { return FREE; } - FROM { return FROM; } + FOR { return FOR; } + FREE { return FREE; } + FROM { return FROM; } FUNCTION { return FUNCTION; } GENERATE { return GENERATE; } GIVING { return GIVING; } GLOBAL { return GLOBAL; } - GO { return GO; } + GO { return GO; } GOBACK { return GOBACK; } - GROUP { return GROUP; } + GROUP { return GROUP; } HEADING { return HEADING; } - IDENTIFICATION { return IDENTIFICATION_DIV; } - IF { return IF; } - IN { return IN; } - INDEX { return INDEX; } + IF { return IF; } + IN { return IN; } + INDEX { return INDEX; } INDEXED { return INDEXED; } INDICATE { return INDICATE; } INITIAL { return INITIAL; } INITIALIZE { return INITIALIZE; } INITIATE { return INITIATE; } - INPUT { return INPUT; } + INPUT { return INPUT; } INSPECT { return INSPECT; } INTERFACE { return INTERFACE; } - INTO { return INTO; } + INTO { return INTO; } INVOKE { return INVOKE; } - IS { return IS; } - KEY { return KEY; } - LAST { return LAST; } + IS { return IS; } + KEY { return KEY; } + LAST { return LAST; } LEADING { return LEADING; } - LEFT { return LEFT; } + LEFT { return LEFT; } LENGTH { return LENGTH; } - LIMIT { return LIMIT; } + LIMIT { return LIMIT; } LIMITS { return LIMITS; } LINAGE { return LINAGE; } - LINE { return LINE; } + LINE { return LINE; } LINE-COUNTER { return LINE_COUNTER; } - LINES { return LINES; } + LINES { return LINES; } LINKAGE { return LINKAGE; } LOCAL-STORAGE { return LOCAL_STORAGE; } LOCALE { return LOCALE; } LOCATION { return LOCATION; } - LOCK { return LOCK; } - MERGE { return MERGE; } - MODE { return MODE; } - MOVE { return MOVE; } + LOCK { return LOCK; } + MERGE { return MERGE; } + MODE { return MODE; } + MOVE { return MOVE; } MULTIPLY { return MULTIPLY; } NATIONAL { return NATIONAL; } NATIONAL-EDITED { return NATIONAL_EDITED; } NATIVE { return NATIVE; } NEGATIVE { return NEGATIVE; } NESTED { return NESTED; } - NEXT { return NEXT; } - NO { return NO; } - NOT { return NOT; } + NEXT { return NEXT; } + NO { return NO; } + NOT { return NOT; } NUMBER { return NUMBER; } NUMERIC { return NUMERIC; } NUMERIC-EDITED { return NUMERIC_EDITED; } OCCURS { return OCCURS; } - OF { return OF; } - OFF { return OFF; } + OF { return OF; } + OFF { return OFF; } OMITTED { return OMITTED; } - ON { return ON; } - OPEN { return OPEN; } + ON { return ON; } + OPEN { return OPEN; } OPTIONAL { return OPTIONAL; } OPTIONS { return OPTIONS; } - OR { return OR; } - ORDER { return ORDER; } - ORGANIZATION { return ORGANIZATION; } - OTHER { return OTHER; } + OR { return OR; } + ORDER { return ORDER; } + ORGANI[SZ]ATION { return ORGANIZATION; } + OTHER { return OTHER; } OUTPUT { return OUTPUT; } OVERFLOW { return OVERFLOW_kw; } OVERRIDE { return OVERRIDE; } PACKED-DECIMAL { return PACKED_DECIMAL; } - PAGE { return PAGE; } + PAGE { return PAGE; } PAGE-COUNTER { return PAGE_COUNTER; } PERFORM { return PERFORM; } - PF { return PF; } - PH { return PH; } - PIC { return PIC; } + PF { return PF; } + PH { return PH; } + PIC { return PIC; } PICTURE { return PICTURE; } - PLUS { return PLUS; } + PLUS { return PLUS; } POINTER { return POINTER; } POSITIVE { return POSITIVE; } PROCEDURE { return PROCEDURE; } - PROGRAM { return PROGRAM; } + PROGRAM { return PROGRAM_kw; } PROGRAM-ID { return PROGRAM_ID; } PROPERTY { return PROPERTY; } PROTOTYPE { return PROTOTYPE; } QUOTES { return QUOTES; } - RAISE { return RAISE; } + RAISE { return RAISE; } RAISING { return RAISING; } RANDOM { return RANDOM; } - RD { return RD; } - READ { return READ; } + RD { return RD; } + READ { return READ; } RECORD { return RECORD; } RECORDS { return RECORDS; } REDEFINES { return REDEFINES; } - REEL { return REEL; } + REEL { return REEL; } REFERENCE { return REFERENCE; } RELATIVE { return RELATIVE; } RELEASE { return RELEASE; } @@ -2368,77 +2401,77 @@ BASIS { yy_push_state(basis); return BASIS; } REPORTS { return REPORTS; } REPOSITORY { return REPOSITORY; } RESERVE { return RESERVE; } - RESET { return RESET; } + RESET { return RESET; } RESUME { return RESUME; } RETURN { return RETURN; } RETURNING { return RETURNING; } REWIND { return REWIND; } REWRITE { return REWRITE; } - RF { return RF; } - RH { return RH; } - RIGHT { return RIGHT; } + RF { return RF; } + RH { return RH; } + RIGHT { return RIGHT; } ROUNDED { return ROUNDED; } - RUN { return RUN; } - SAME { return SAME; } + RUN { return RUN; } + SAME { return SAME; } SCREEN { return SCREEN; } - SD { return SD; } + SD { return SD; } SEARCH { return SEARCH; } - SECTION { return SECTION; } + SECTION { yylval.string = NULL; return SECTION; } SELECT { return SELECT; } SENTENCE { return SENTENCE; } SEPARATE { return SEPARATE; } SEQUENCE { return SEQUENCE; } SEQUENTIAL { return SEQUENTIAL; } - SET { return SET; } + SET { return SET; } SHARING { return SHARING; } - SIGN { return SIGN; } - SIZE { return SIZE; } - SORT { return SORT; } + SIGN { return SIGN; } + SIZE { return SIZE; } + SORT { return SORT; } SORT-MERGE { return SORT_MERGE; } SOURCE { return SOURCE; } - SPACE { return SPACE; } + SPACE { return SPACE; } SPACES { return SPACES; } SPECIAL-NAMES { return SPECIAL_NAMES; } STANDARD { return STANDARD; } STANDARD-1 { return STANDARD_1; } - START { return START; } + START { return START; } STATUS { return STATUS; } - STOP { return STOP; } + STOP { return STOP; } SUBTRACT { return SUBTRACT; } - SUM { return SUM; } + SUM { return SUM; } SUPPRESS { return SUPPRESS; } SYMBOLIC { return SYMBOLIC; } TALLYING { return TALLYING; } TERMINATE { return TERMINATE; } - TEST { return TEST; } - THAN { return THAN; } - THEN { return THEN; } - THRU { return THRU; } - TIME { return TIME; } - TIMES { return TIMES; } - TO { return TO; } - TOP { return TOP; } + TEST { return TEST; } + THAN { return THAN; } + THEN { return THEN; } + THRU { return THRU; } + TIME { return TIME; } + TIMES { return TIMES; } + TO { return TO; } + TOP { return TOP; } TRAILING { return TRAILING; } - TYPE { return TYPE; } + TYPE { return TYPE; } TYPEDEF { return TYPEDEF; } - UNIT { return UNIT; } - UNTIL { return UNTIL; } - UP { return UP; } - UPON { return UPON; } - USAGE { return USAGE; } - USE { return USE; } - USING { return USING; } - VALUE { return VALUE; } + UNIT { return UNIT; } + UNTIL { return UNTIL; } + UP { return UP; } + UPON { return UPON; } + USAGE { return USAGE; } + USE { return USE; } + USING { return USING; } + VALUE { return VALUE; } VARYING { return VARYING; } - WHEN { return WHEN; } - WITH { return WITH; } + WHEN { return WHEN; } + WITH { return WITH; } WORKING-STORAGE { return WORKING_STORAGE; } - WRITE { return WRITE; } + WRITE { return WRITE; } ZERO | ZEROES | - ZEROS { return ZERO; } + ZEROS { return ZERO; } } <*>{ @@ -2475,29 +2508,13 @@ BASIS { yy_push_state(basis); return BASIS; } return NO_CONDITION; } -<<EOF>> { - - if( YY_START == quoted1 || YY_START == quoted2 ) { - error_msg(yylloc, "syntax error: unterminated string '%s'", +<quoted1,quoted2>{ + <<EOF>> { + error_msg(yylloc, "syntax error: unterminated string %<%s%>", tmpstring); return NO_CONDITION; - cbl_internal_error(""); - } - yypop_buffer_state(); - - if ( !YY_CURRENT_BUFFER ) { - return 0; - } - - if( ! wait_for_the_child() ) { - yyterminate(); - } - cobol_filename_restore(); - parser_leave_file(); - - if( yydebug ) yywarn("resume parsing '%s'", cobol_filename()); - yy_set_bol(true); - } + } +} %% diff --git a/gcc/cobol/scan_ante.h b/gcc/cobol/scan_ante.h index c8c93ed..31093a6 100644 --- a/gcc/cobol/scan_ante.h +++ b/gcc/cobol/scan_ante.h @@ -149,7 +149,7 @@ numstr_of( const char string[], radix_t radix = decimal_e ) { } auto nx = std::count_if(input, p, fisdigit); if( 36 < nx ) { - error_msg(yylloc, "significand of %s has more than 36 digits (%zu)", input, nx); + error_msg(yylloc, "significand of %s has more than 36 digits (%td)", input, nx); return NO_CONDITION; } @@ -159,11 +159,11 @@ numstr_of( const char string[], radix_t radix = decimal_e ) { // exponent is implementor-defined." (We allow 9999.) nx = std::count_if(p, eoinput, fisdigit); if( 4 < nx ) { - error_msg(yylloc, "exponent %s more than 4 digits", ++p); + error_msg(yylloc, "exponent %qs more than 4 digits", ++p); return NO_CONDITION; } if( eoinput != std::find(p, eoinput, symbol_decimal_point()) ) { - error_msg(yylloc, "exponent includes decimal point", ++p); + error_msg(yylloc, "exponent %qs includes decimal point", ++p); return NO_CONDITION; } @@ -187,7 +187,7 @@ numstr_of( const char string[], radix_t radix = decimal_e ) { } } if( 1 < std::count(input, eoinput, symbol_decimal_point()) ) { - error_msg(yylloc, "invalid numeric literal", ++p); + error_msg(yylloc, "invalid numeric literal %qs", ++p); return NO_CONDITION; } @@ -214,7 +214,11 @@ struct cdf_status_t { const char *filename; int token; bool parsing; - cdf_status_t( int token = 0, bool parsing = true ) + cdf_status_t() + : lineno(yylineno), filename(cobol_filename()) + , token(0), parsing(true) + {} + cdf_status_t( int token, bool parsing ) : lineno(yylineno), filename(cobol_filename()) , token(token), parsing(parsing) {} @@ -291,7 +295,7 @@ static class parsing_status_t : public std::stack<cdf_status_t> { void splat() const { int i=0; for( const auto& status : c ) { - yywarn( "%4d\t%s", ++i, status.str() ); + yywarn( "%d %s", ++i, status.str() ); } } } parsing; @@ -301,7 +305,7 @@ void field_done() { orig_picture[0] = '\0'; parsing.need_level(true); } static int scanner_token() { if( parsing.empty() ) { - error_msg(yylloc, ">>ELSE or >>END-IF without >>IF"); + error_msg(yylloc, "%<>>ELSE%> or %<>>END-IF%> without %<>>IF%>"); return NO_CONDITION; } return parsing.top().token; @@ -313,31 +317,32 @@ bool scanner_normal() { return parsing.normal(); } void scanner_parsing( int token, bool tf ) { parsing.push( cdf_status_t(token, tf) ); if( yydebug ) { - yywarn("%10s: parsing now %5s, depth %zu", + yywarn("%s: parsing now %s, depth %zu", keyword_str(token), boolalpha(parsing.on()), parsing.size()); parsing.splat(); } } void scanner_parsing_toggle() { if( parsing.empty() ) { - error_msg(yylloc, ">>ELSE without >>IF"); + error_msg(yylloc, "%<>>ELSE%> without %<>>IF%>"); return; } parsing.top().toggle(); if( yydebug ) { - yywarn("%10s: parsing now %5s", + yywarn("%s: parsing now %s", keyword_str(CDF_ELSE), boolalpha(parsing.on())); } } void scanner_parsing_pop() { if( parsing.empty() ) { - error_msg(yylloc, ">>END-IF without >>IF"); + error_msg(yylloc, "%<>>END-IF%> without %<>>IF%>"); return; } parsing.pop(); if( yydebug ) { - yywarn("%10s: parsing now %5s, depth %zu", - keyword_str(CDF_END_IF), boolalpha(parsing.on()), parsing.size()); + yywarn("%s: parsing now %s, depth %zu", + keyword_str(CDF_END_IF), boolalpha(parsing.on()), + parsing.size()); parsing.splat(); } } @@ -351,6 +356,10 @@ static void level_found() { if( scanner_normal() ) parsing.need_level(false); } +/* + * Trim the scanned location by the amount about to re-scanned. + * Must be a macro because it expands yyless. + */ #define myless(N) \ do { \ auto n(N); \ @@ -368,8 +377,9 @@ class enter_leave_t { public: enter_leave_t() : entering(NULL), leaving(NULL), filename(NULL) {} enter_leave_t( parser_enter_file_f *entering, const char *filename ) - : entering(entering), leaving(NULL), filename(filename) {} - enter_leave_t(parser_leave_file_f *leaving) + : entering(entering), leaving(NULL), filename(filename) + {} + explicit enter_leave_t(parser_leave_file_f *leaving) : entering(NULL), leaving(leaving), filename(NULL) {} void notify() { @@ -381,9 +391,9 @@ class enter_leave_t { gcc_assert(leaving == NULL); } if( leaving ) { - auto name = cobol_filename_restore(); + cobol_filename_restore(); if( yy_flex_debug ) dbgmsg("resuming line %4d of %s", - yylineno, name? name : "<none>"); + yylineno, cobol_filename()); leaving(); gcc_assert(entering == NULL); } @@ -397,7 +407,7 @@ static class input_file_status_t { inputs.push( enter_leave_t(parser_enter_file, filename) ); } void leave() { - inputs.push( parser_leave_file ); + inputs.push( enter_leave_t(parser_leave_file) ); } void notify() { while( ! inputs.empty() ) { @@ -410,26 +420,60 @@ static class input_file_status_t { void input_file_status_notify() { input_file_status.notify(); } -void cdf_location_set(YYLTYPE loc); +/* + * parse.y and cdf.y each define a 4-integer struct to hold a token's location. + * parse.y uses YYLTYPE yylloc; + * cdf.y uses YDFLLTYPE ydflloc; + * + * The structs have identical definitions with different types and of course + * names. We define "conversion" between them for convenience. + * + * Each parser expects its location value to be updated whenever it calls + * yylex(). Therefore, here in the lexer we set both locations as each token + * is scanned, so that both parsers see the same location. + */ +static YDFLTYPE +ydfltype_of( const YYLTYPE& loc ) { + YDFLTYPE output { + loc.first_line, loc.first_column, + loc.last_line, loc.last_column }; + return output; +} +/* + * After the input filename and yylineno are set, update the location of the + * scanned token. + */ static void -update_location() { +update_location( const YYLTYPE *ploc = nullptr ) { YYLTYPE loc = { yylloc.last_line, yylloc.last_column, yylineno, yylloc.last_column + yyleng }; + if( ploc ) loc = *ploc; - auto nline = std::count(yytext, yytext + yyleng, '\n'); - if( nline ) { - char *p = static_cast<char*>(memrchr(yytext, '\n', yyleng)); + const char *p = static_cast<char*>(memrchr(yytext, '\n', yyleng)); + if( p ) { loc.last_column = (yytext + yyleng) - p; } yylloc = loc; - cdf_location_set(loc); - location_dump(__func__, __LINE__, "yylloc", yylloc); + ydflloc = ydfltype_of(yylloc); + + dbgmsg(" SC: %s location (%d,%d) to (%d,%d)", + start_condition_is(), + yylloc.first_line, yylloc.first_column, + yylloc.last_line, yylloc.last_column); +} + +static void +reset_location() { + static const YYLTYPE loc { yylineno, 1, yylineno, 1 }; + update_location(&loc); } +#define YY_USER_ACTION update_location(); + static void trim_location( int nkeep) { gcc_assert( 0 <= nkeep && nkeep <= yyleng ); @@ -446,7 +490,8 @@ trim_location( int nkeep) { (fmt_size_t)nline, (fmt_size_t)rescan.size()); if( nline ) { gcc_assert( yylloc.first_line + nline <= yylloc.last_line ); - yylloc.last_line =- int(nline); + yylloc.last_line -= int(nline); + gcc_assert( yylloc.first_line <= yylloc.last_line ); char *p = static_cast<char*>(memrchr(rescan.p, '\n', rescan.size())); yylloc.last_column = rescan.pend - ++p; return; @@ -474,7 +519,8 @@ update_location_col( const char str[], int correction = 0) { #define YY_USER_INIT do { \ static YYLTYPE ones = {1,1, 1,1}; \ - yylloc = ones; \ + yylloc = ones; \ + ydflloc = ydfltype_of(yylloc); \ } while(0) /* @@ -483,15 +529,11 @@ update_location_col( const char str[], int correction = 0) { * updates neither yylval nor yylloc. That job is left to the actions. * * The parser relies on yylex to set yylval and yylloc each time it is - * called. It apparently maintains a separate copy for each term, and uses + * called. It maintains a separate copy for each term, and uses * YYLLOC_DEFAULT() to update the location of nonterminals. */ #define YY_DECL int lexer(void) -#define YY_USER_ACTION \ - update_location(); \ - if( yy_flex_debug ) dbgmsg("SC: %s", start_condition_is() ); - # define YY_INPUT(buf, result, max_size) \ { \ if( 0 == (result = lexer_input(buf, max_size, yyin)) ) \ @@ -567,11 +609,14 @@ static const std::map <std::string, bint_t > binary_integers { static int binary_integer_usage( const char name[]) { - cbl_name_t uname = {}; + // uname can't be cbl_name_t, because at this point name[] might have more + // than sizeof(cbl_name_t) characters. The length check comes later. + char *uname = xstrdup(name); std::transform(name, name + strlen(name), uname, ftoupper); dbgmsg("%s:%d: checking %s in %zu keyword_aliases", - __func__, __LINE__, uname, keyword_aliases.size() ); + __func__, __LINE__, uname, + keyword_aliases.size() ); std::string key = uname; auto alias = keyword_aliases.find(key); @@ -585,9 +630,20 @@ binary_integer_usage( const char name[]) { yylval.computational.signable = p->second.signable; dbgmsg("%s:%d: %s has type %d", __func__, __LINE__, uname, p->second.type ); + free(uname); return p->second.token; } +static void +verify_ws( const YYLTYPE& loc, const char input[], char ch ) { + if( ! fisspace(ch) ) { + if( ! (dialect_mf() || dialect_gnu()) ) { + dialect_error(loc, "separator space required in %qs", input); + } + } +} +#define verify_ws(C) verify_ws(yylloc, yytext, C) + int binary_integer_usage_of( const char name[] ) { cbl_name_t uname = {}; @@ -641,6 +697,387 @@ picset( int token ) { return token; } +/** +## Script and data to produce picture_t::followers. +## Based on ISO Table 10. +#! /usr/bin/awk -f + +BEGIN { + str = "B0/ , . + +- +- CR/DB cs cs Z* Z* + + cs cs 9 AX S V P P 1 N E" + split(str, cols) +} + +$1 ~ /CR|DB|cs/ { next } + +0 && !nlines++ { + for( i=0; i < length(cols); i++ ) { + print i, cols[i], "'" $i "'" + } +} + +$field == "x" { + if( ! nout++ ) { + printf "%2d: %5s: \"", field, cols[field - 1] + } + + gsub(/^ +| +$/, "", $1) + printf "%s", $1 +} + +END { + if( ! nout++ ) { + printf "%2d: %5s: \"", field, cols[field - 1] + } + print "\"" +} + +B x x x - x - - x - x x x x x x x x - x - x - x +0 x x x - x - - x - x x x x x x x x - x - x - x +/ x x x - x - - x - x x x x x x x x - x - x - x +, x x x - x - - x - x x x x x x x - - x - x +. x x - - x - - x - x - x - x - x ++ - - - - - - - - - - - - - - - - - - - - - - - x ++ +– ++ x x x - - - - x x x x - - x x x - - x x x +CR x x x - - - - x x x x - - x x x - - x x x +DB x x x - - - - x x x x - - x x x - - x x x +cs - - - - x +cs x x x - x - - - - x x - - - - x - - x x x + +Z x x - - x - - x - x +* x x - - x - - x - x +Z x x x - x - - x - x x - - - - - - - x - x +* x x x - x - - x - x x - - - - - - - x - x ++ x x - - - - - x - - - x +– x x - - - - - x - - - x ++ x x x - - - - x - - - x x - - - - - x +– x x x - - - - x - - - x x - - - - - x +cs x x - - x - - - - - - - - x +cs x x x - x - - - - - - - - x x - - - x + +9 x x x x x - - x - x - x - x - x x x x - x - - x +A x - - - - - - - - - - - - - - x x +X x - - - - - - - - - - - - - - x x +S +V x x - - x - - x - x - x - x - x - x - x +P x x - - x - - x - x - x - x - x - x - x +P - - - - x - - x - - - - - - - - - x x - x +1 - - - - - - - - - - - - - - - - - - - - - x +N x - - - - - - - - - - - - - - - - - - - - - x +E x x x - x - - - - - - - - - - x +**/ + +class picture_t { + static const char dot = '.', comma = ','; + + typedef std::vector<std::string> followings_t; + static const std::map <char, followings_t> followers; + + const char * const begin; + const char *p, *pend; + size_t pos; + struct exclusions_t { // Nonzero if set, > 1 is false. + // crdb means CR/DB or +/-. + // pluses means 2 or more consecutive '+'. + // minuses means 2 or more consecutive '-'. + // "21) The symbol 'Z' and the symbol '*' are mutually exclusive " + // stars means '*' or Z. + unsigned short int crdb, currency, dot, pluses, minuses, stars, zzz; + exclusions_t() + : crdb(0), currency(0), dot(0), pluses(0), minuses(0), stars(0) + {} + } exclusions; + YYLTYPE loc; + + bool is_crdb() const { // input must be uppercase for CR/DB + if( p[0] == 'C' || p[0] == 'D' ) { + char input[3] = { p[0], p[1] }; + return ( 0 == strcmp(input, "CR") || 0 == strcmp(input, "DB") ); + } + return false; + } + + const char * match_paren( const char *paren ) const { + gcc_assert(paren[0] == '('); // start with opening paren + paren = std::find_if( paren, pend, + []( char ch ) { + return ch == '(' || ch == ')'; + } ); + if( *paren == '(' ) return nullptr; // no nesting + if( paren == pend ) return nullptr; + return ++paren; + } + + const char * next_not( char ch ) const { + return std::find_if( p, pend, + [ch = TOUPPER(ch)]( char next ) { + return ch != next; + } ); + } + + const char * valid_next( const char *p, const std::string& valid ) const { + if( p == pend || p + 1 == pend ) return pend; + if( p[1] == '(' ) { + return match_paren(++p); + } + auto pv = std::find(valid.begin(), valid.end(), TOUPPER(p[1])); + return pv != valid.end()? ++p : nullptr; + } + const char * valid_next( const char *p, + bool first = true, char ch = '\0' ) const { + if( p == pend || p + 1 == pend ) return pend; + if( p[0] == '(' ) { + if( (p = match_paren(p)) == nullptr ) return nullptr; + } + if( p[0] == '(' ) return nullptr; // consecutive parentheses + + int index = first? 0 : 1; + if( !ch ) ch = *p; // use current character unless overridden + auto valid = followers.find(TOUPPER(ch)); + if( valid == followers.end() ) { + YYLTYPE loc(yylloc); + loc.first_column += int(p - begin); + error_msg( loc, "PICTURE: strange character %qc, giving up", ch ); + return nullptr; + } + return valid_next(p, valid->second[index]); + } + + const char * start() { // start modifies exclusions, but not p + auto pnext = p; + + switch(TOUPPER(p[0])) { + case comma: case dot: + // use decimal_is_comma() + // 4: .: "B0/,+Z*+-9E" + exclusions.dot++; + pnext = valid_next(p, "B0/,+Z*+-9E"); + break; + case '+': case '-': + // 6: +-: "B0/,.Z*Z*9VPPE" + exclusions.crdb++; + pnext = next_not(p[0]); + if( p + 1 < pnext ) { + exclusions.pluses++; + } + pnext = valid_next(--pnext, "B0/,.Z*Z*9VPPE"); + break; + case 'Z': case '*': + exclusions.stars++; + pnext = next_not(p[0]); + break; + case 'S': + // 19: S: "9VP" + pnext = valid_next(p, "9VP"); + break; + } + + /* + * "For fixed editing sign control, the currency symbol, when used, shall + * be either the leftmost symbol in character-string-1, optionally preceded + * by one of the symbols '+' or '-' " + */ + if( pnext ) { + if( p == pnext || p[0] == '+' || p[0] == '-' ) { + if( symbol_currency(*pnext) ) { + exclusions.currency++; + pnext = next_not(*pnext); + pnext = valid_next(--pnext, true, '$'); + } + } + } + + return pnext; + } + + const char * next() { // modify state; do not modify position + auto pnext = p; + auto loc(picture_t::loc); + loc.first_column += int(p - begin); + + if( is_crdb() ) { + if( exclusions.crdb++ ) { + error_msg( loc, "PICTURE: CR/DB and %c/%c may appear only once", '+', '-' ); + return nullptr; + } + if( p + 2 != pend ) { + error_msg( loc, "PICTURE: CR/DB must appear at the end" ); + return nullptr; + } + return pend; + } + + if( symbol_currency(p[0]) ) { + if( false && exclusions.currency++ ) { // not enforced + error_msg( loc, "PICTURE: CURRENCY SYMBOL sequence may appear at most once" ); + return nullptr; + } + return valid_next(p, ! exclusions.dot, '$'); + } + + switch(TOUPPER(p[0])) { + case '(': + return match_paren(p); + break; + case 'B': case '0': case '/': + pnext = valid_next(p); + break; + case comma: + if( decimal_is_comma() ) { + if( exclusions.dot++ ) { + error_msg( loc, "PICTURE: %qc: may appear at most once", p[0] ); + return nullptr; + } + pnext = valid_next(p, true, dot); + } else { + pnext = valid_next(p); + } + break; + case dot: + if( p + 1 == pend ) { + pnext = pend; + } else { + if( decimal_is_comma() ) { + pnext = valid_next(p, true, comma ); + } else { + if( exclusions.dot++ ) { + error_msg( loc, "PICTURE: %qc: may appear at most once", p[0] ); + return nullptr; + } + pnext = valid_next(p); + } + } + break; + + case '+': case '-': + // 7 is trailing sign; 13 & 14 are numeric. Leading sign handled by start(). + if( p + 1 == pend ) { + if( exclusions.crdb++ ) { + error_msg( loc, "PICTURE: %c/%c may appear at most once as a sign", '+', '-' ); + return nullptr; + } + pnext = pend; + } else { + pnext = next_not(p[0]); + if( p + 1 < pnext ) { + if( false && exclusions.pluses++ ) { // not enforced + error_msg( loc, "PICTURE: %qc: sequence may appear at most once", p[0] ); + return nullptr; + } + } + pnext = valid_next(pnext, ! exclusions.dot); + } + break; + + case 'Z': case '*': + if( false && exclusions.stars++ ) { // not enforced + error_msg( loc, "PICTURE: %qc: sequence may appear at most once", p[0] ); + return nullptr; + } + if( (pnext = next_not(p[0])) == nullptr ) return pnext; + pnext = valid_next(pnext, ! exclusions.dot); + break; + case 'P': + pnext = valid_next(pnext, ! exclusions.dot); + break; + case '9': + case 'A': case 'X': + case 'V': + case '1': + case 'N': + pnext = valid_next(p); + break; + case 'E': + pnext = valid_next(p, "+9"); + if( pnext && *pnext == '+' ) { + pnext = valid_next(p, "9"); + } + break; + default: + error_msg( loc, "PICTURE: %qc: invalid character", p[0] ); + return nullptr; + } + return pnext; + } + + public: + picture_t( const char *p, int len ) + : begin(p) + , p(p), pend(p + len) + , loc(yylloc) + { + assert(TOUPPER(*p) == 'P'); // as in PICTURE (or PICTURE IS) + // move p to start of picture string + while( (p = std::find_if(p, pend, fisspace)) != pend ) { + this->p = p = std::find_if(p, pend, + []( char ch ) { return ! fisspace(ch); } ); + } + assert(this->p != pend); + pos = this->p - begin; + } + + bool is_valid() { + if( !p ) return false; + if( (p = start()) == nullptr ) { + return false; + } + + while( p && p < pend) { + p = next(); + } + return p == pend; + } + + int starts_at() const { return pos; } +}; + +/* + * The Followers map gives 1 or 2 lists of valid characters following a + * character, the one in the key. If there are two lists, the correct one is + * determined by the caller based on the state of the picture string, i.e., + * what has been seen before. + */ +const std::map <char, picture_t::followings_t> picture_t::followers { + /* B0/ */ { 'B', {"B0/,.Z*+-9AXVPNE" } }, + /* B0/ */ { '0', {"B0/,.Z*+-9AXVPNE" } }, + /* B0/ */ { '/', {"B0/,.Z*+-9AXVPNE" } }, + /* , */ { ',', {"B0/,.Z*+-9VPE"} }, + /* . */ { '.', {"B0/,Z*+-9E"} }, + /* + { '+', "9" }, */ + /* +- */ { '+', {"B0/,.Z*9VPE", "" } }, + /* +- */ { '-', {"B0/,.Z*9VPE", "" } }, + /* CR/DB { 'C', "" }, */ + /* cs { 'c', "B0/,.Z*+-9VP" }, */ + /* cs { 'c', "+" }, */ + /* Z* */ { 'Z', {"B0/,.+Z*9VP", "B0/,+Z*"} }, + /* Z* */ { '*', {"B0/,.+Z*9VP", "B0/,+Z*"} }, + /* + */ { '+', {"B0/,.+-9VP", "B0/,+-"} }, + /* cs */ { '$', {"B0/,.+9VP", "B0/,+"} }, + /* 9 */ { '9', {"B0/,.+9AXVPE"} }, + /* AX */ { 'A', {"B0/9AX"} }, + /* AX */ { 'X', {"B0/9AX"} }, + /* S */ { 'S', {"9VP"} }, + /* V */ { 'V', {"B0/,+Z*+-9P"} }, + /* P */ { 'P', {"+VP", "B0/,+Z*9P"} }, + /* 1 */ { '1', {"1"} }, + /* N */ { 'N', {"B0/N"} }, + /* E */ { 'E', {"+9"} }, +}; + +/* + * Although picture_t::is_valid return a bool, it's not used. The validation + * routines emit messages where the error is detected. The entire string is + * subsequently parsed by the parser, which might otherwise accept an invalid + * string, but will usually emit a message of its own. + */ +static int +validate_picture() { + picture_t picture(yytext, yyleng); + picture.is_valid(); + return picture.starts_at(); +} + static inline bool is_integer_token( int *pvalue = NULL ) { int v, n = 0; @@ -657,7 +1094,7 @@ bool need_nume_set( bool tf ) { static int datetime_format_of( const char input[] ); static int symbol_function_token( const char name[] ) { - auto e = symbol_function( 0, name ); + const auto e = symbol_function( 0, name ); return e ? symbol_index(e) : 0; } @@ -731,6 +1168,10 @@ typed_name( const char name[] ) { { auto f = cbl_field_of(e); if( is_constant(f) ) { + if( f->data.initial ) { + int token = cbl_figconst_tok(f->data.initial); + if( token ) return token; + } int token = datetime_format_of(f->data.initial); if( token ) { yylval.string = xstrdup(f->data.initial); @@ -741,7 +1182,7 @@ typed_name( const char name[] ) { __attribute__((fallthrough)); case FldLiteralN: { - auto f = cbl_field_of(e); + const auto f = cbl_field_of(e); if( type == FldLiteralN ) { yylval.numstr.radix = f->has_attr(hex_encoded_e)? hexadecimal_e : decimal_e; @@ -775,7 +1216,7 @@ typed_name( const char name[] ) { return cbl_field_of(e)->level == 88? NAME88 : CLASS_NAME; break; default: - yywarn("%s:%d: invalid symbol type %s for symbol \"%s\"", + yywarn("%s:%d: invalid symbol type %s for symbol %qs", __func__, __LINE__, cbl_field_type_str(type), name); return NAME; } @@ -797,32 +1238,6 @@ tmpstring_append( int len ) { #define pop_return yy_pop_state(); return -static bool -wait_for_the_child(void) { - pid_t pid; - int status; - - if( (pid = wait(&status)) == -1 ) { - yywarn("internal error: no pending child CDF parser process"); - return false; - } - - if( WIFSIGNALED(status) ) { - yywarn( "process %d terminated by %s", pid, strsignal(WTERMSIG(status)) ); - return false; - } - if( WIFEXITED(status) ) { - if( WEXITSTATUS(status) != 0 ) { - yywarn("process %d exited with status %d", pid, status); - return false; - } - } - if( yy_flex_debug ) { - yywarn("process %d exited with status %d", pid, status); - } - return true; -} - static bool is_not = false; static uint64_t diff --git a/gcc/cobol/scan_post.h b/gcc/cobol/scan_post.h index 85feac8..7cf2b98 100644 --- a/gcc/cobol/scan_post.h +++ b/gcc/cobol/scan_post.h @@ -34,7 +34,6 @@ start_condition_str( int sc ) { switch(sc) { case INITIAL: state = "INITIAL"; break; case addr_of: state = "addr_of"; break; - case author_state: state = "author_state"; break; case basis: state = "basis"; break; case bool_state: state = "bool_state"; break; case cdf_state: state = "cdf_state"; break; @@ -116,10 +115,10 @@ datetime_format_of( const char input[] ) { for( auto p = patterns; p < eopatterns; p++ ) { static const int cflags = REG_EXTENDED | REG_ICASE; - static char msg[80]; int erc; if( 0 != (erc = regcomp(&p->re, p->regex, cflags)) ) { + static char msg[80]; regerror(erc, &p->re, msg, sizeof(msg)); yywarn("%s:%d: %s: %s", __func__, __LINE__, keyword_str(p->token), msg); } @@ -159,6 +158,8 @@ is_cdf_token( int token ) { case CDF_DISPLAY: case CDF_IF: case CDF_ELSE: case CDF_END_IF: case CDF_EVALUATE: case CDF_WHEN: case CDF_END_EVALUATE: + case CDF_PUSH: + case CDF_POP: return true; case CALL_COBOL: case CALL_VERBATIM: @@ -260,13 +261,12 @@ prelex() { while( is_cdf_token(token) ) { if( ! run_cdf(token) ) { - dbgmsg( ">>CDF parser failed" ); - return NO_CONDITION; + dbgmsg( ">>CDF parser failed, ydfchar %d", ydfchar ); } // Return the CDF's discarded lookahead token, if extant. token = ydfchar > 0? ydfchar : next_token(); if( token == NO_CONDITION && parsing.at_eof() ) { - return token = YYEOF; + return YYEOF; } // Reenter cdf parser only if next token could affect parsing state. @@ -298,7 +298,7 @@ prelex() { token = LEVEL; break; case YDF_NUMBER: - if( yy_flex_debug ) yywarn("final token is YDF_NUMBER"); + if( yy_flex_debug ) yywarn("final token is %<YDF_NUMBER%>"); yylval.number = ydflval.number; token = LEVEL; break; @@ -375,7 +375,7 @@ yylex(void) { token = prelex(); if( yy_flex_debug ) { if( parsing.in_cdf() ) { - dbgmsg( "%s:%d: %s routing %s to CDF parser", __func__, __LINE__, + dbgmsg( "%s:%d: <%s> routing %s to CDF parser", __func__, __LINE__, start_condition_is(), keyword_str(token) ); } else if( !parsing.on() ) { dbgmsg( "eating %s because conditional compilation is FALSE", diff --git a/gcc/cobol/show_parse.h b/gcc/cobol/show_parse.h index f7ab982..bd0e16f 100644 --- a/gcc/cobol/show_parse.h +++ b/gcc/cobol/show_parse.h @@ -147,10 +147,10 @@ extern bool cursor_at_sol; fprintf(stderr, "<%s>", cbl_field_type_str((b).field->type)); \ } \ } \ - if( (b).nsubscript) \ + if( (b).nsubscript()) \ { \ fprintf(stderr,"("); \ - for(size_t jjj=0; jjj<(b).nsubscript; jjj++) \ + for(size_t jjj=0; jjj<(b).nsubscript(); jjj++) \ { \ if(jjj) \ { \ @@ -176,11 +176,21 @@ extern bool cursor_at_sol; } \ else \ { \ - fprintf(stderr, " %p:%s (%s)", (void*)b, b->name, b->type_str()); \ + fprintf(stderr, " %p:%s (%s)", static_cast<void*>(b), b->name, b->type_str()); \ } \ show_parse_sol = false; \ } while(0); +// Use this version when b is known to be valid. This is necessary to quiet +// cppcheck nullPointerRedundantCheck warnings +#define SHOW_PARSE_LABEL_OK(a, b) \ + do \ + { \ + fprintf(stderr, "%s", a); \ + fprintf(stderr, " %p:%s (%s)", static_cast<void*>(b), b->name, b->type_str()); \ + show_parse_sol = false; \ + } while(0); + #define TRACE1 if(bTRACE1) #define TRACE1_HEADER do \ { \ @@ -211,6 +221,7 @@ extern bool cursor_at_sol; #define TRACE1_FIELD_VALUE(a, field, b) \ do \ { \ + gcc_assert(field); \ cursor_at_sol=false; \ if ( field->type == FldConditional ) \ { \ @@ -337,13 +348,13 @@ extern bool cursor_at_sol; else \ { \ gg_fprintf(trace_handle, 1, "%s", gg_string_literal( (b).field->name ? (b).field->name:"")); \ - if( b.nsubscript ) \ + if( b.nsubscript() ) \ { \ gg_fprintf(trace_handle, 0, "("); \ - for(unsigned int i=0; i<b.nsubscript; i++) \ + for(unsigned int i=0; i<b.nsubscript(); i++) \ { \ gg_fprintf(trace_handle, 1, "%s", gg_string_literal( b.subscripts[i].field->name ? b.subscripts[i].field->name : "" )); \ - if( i<b.nsubscript-1 ) \ + if( i<b.nsubscript()-1 ) \ { \ gg_fprintf(trace_handle, 0, " "); \ } \ @@ -423,31 +434,61 @@ extern bool cursor_at_sol; } while(0); // Use CHECK_FIELD when a should be non-null, and a->var_decl_node also should -// by non-null: -#define CHECK_FIELD(a) \ - do{ \ - if(!a) \ - { \ - yywarn("%s(): parameter " #a " is NULL", __func__); \ - gcc_unreachable(); \ - } \ - if( !a->var_decl_node && a->type != FldConditional && a->type != FldLiteralA) \ - { \ - yywarn("%s() parameter " #a " is variable %s<%s> with NULL var_decl_node", \ - __func__, \ - a->name, \ - cbl_field_type_str(a->type) ); \ - gcc_unreachable(); \ - } \ - }while(0); - -#define CHECK_LABEL(a) \ - do{ \ - if(!a) \ - { \ - yywarn("%s(): parameter " #a " is NULL", __func__); \ - gcc_unreachable(); \ - } \ +// by non-null. (The useless calls to abort() are because cppcheck doesn't +// understand that gcc_unreachable doesn't return); + +// Use this after doing any SHOW_PARSE stuff, to avoid cppcheck complaints +// about nullPointerRedundantCheck +#define CHECK_FIELD(a) \ + do { \ + if(!a) \ + { \ + yywarn("%s: parameter %<" #a "%> is NULL", __func__); \ + gcc_unreachable(); \ + abort(); \ + } \ + if( !a->var_decl_node ) \ + { \ + yywarn("%s: parameter %<" #a "%> is variable " \ + "%s<%s> with NULL %<var_decl_node%>", \ + __func__, \ + a->name, \ + cbl_field_type_str(a->type) ); \ + gcc_unreachable(); \ + abort(); \ + } \ + } while(0); + +// This version is a bit more lax, for special cases +#define CHECK_FIELD2(a) \ + do { \ + if(!a) \ + { \ + yywarn("%s: parameter %<" #a "%> is NULL", __func__); \ + gcc_unreachable(); \ + abort(); \ + } \ + if( !a->var_decl_node && a->type != FldConditional && a->type != FldLiteralA) \ + { \ + yywarn("%s: parameter %<" #a "%> is variable " \ + "%s<%s> with NULL %<var_decl_node%>", \ + __func__, \ + a->name, \ + cbl_field_type_str(a->type) ); \ + gcc_unreachable(); \ + abort(); \ + } \ + } while(0); + + +#define CHECK_LABEL(a) \ + do{ \ + if(!a) \ + { \ + yywarn("%s: parameter %<" #a "%> is NULL", __func__); \ + gcc_unreachable(); \ + abort(); \ + } \ }while(0); #ifdef INCORPORATE_ANALYZER @@ -503,10 +544,11 @@ class ANALYZE } }; #else +// cppcheck-suppress ctuOneDefinitionRuleViolation class ANALYZE { public: - ANALYZE(const char *) + explicit ANALYZE(const char *) { } ~ANALYZE() diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index 1d0acf90..f2cd1b5 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -28,6 +28,8 @@ * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ +// cppcheck-suppress-file duplicateBreak + #include "config.h" #include <fstream> // Before cobol-system because it uses poisoned functions #include "cobol-system.h" @@ -56,7 +58,7 @@ class symbol_pair_t { const symbol_elem_t *first, *last; public: - symbol_pair_t( const symbol_elem_t * first, const symbol_elem_t * end = NULL ) + explicit symbol_pair_t( const symbol_elem_t * first, const symbol_elem_t * end = NULL ) : first(first), last(end) {} @@ -136,11 +138,9 @@ static struct symbol_table_t { static symbol_table_t& symbol_table_extend() { - static FILE *mapped; if( symbols.nelem == 0 ) { // first time: create file & set initial capacity - assert(mapped == NULL && symbols.fd == -1); - + FILE *mapped; if( (mapped = tmpfile()) == NULL ) { cbl_err( "could not create temporary file for symbol table"); } @@ -160,8 +160,8 @@ symbol_table_extend() { off_t len = symbols.size(); if( 0 != ftruncate(symbols.fd, len) ) { - cbl_err( "%s:%d:could not extend symbol table to %zu elements", - __func__, __LINE__, symbols.capacity); + cbl_err( "%s:%d: could not extend symbol table to %lu elements", + __func__, __LINE__, gb4(symbols.capacity)); } /* @@ -229,6 +229,12 @@ cbl_span_t::from_field() { assert(from); return from->field; } cbl_field_t * cbl_span_t::len_field() { assert(len); return len->field; } +cbl_ffi_arg_t::cbl_ffi_arg_t() + : optional(false) + , crv(by_reference_e) + , attr(none_of_e) +{} + cbl_ffi_arg_t:: cbl_ffi_arg_t( cbl_refer_t* refer, cbl_ffi_arg_attr_t attr ) : optional(false) @@ -257,43 +263,6 @@ cbl_ffi_arg_t( cbl_ffi_crv_t crv, } while(0) -cbl_field_t * -symbol_valid_udf_args( size_t function, std::list<cbl_refer_t> args ) { - auto L = cbl_label_of(symbol_at(function)); - if( ! L->returning ) { - dbgmsg("logic error: %s does not define RETURNING", L->name); - return NULL; - } - auto e = std::find_if( symbol_at(function), symbols_end(), - []( auto symbol ) { - if( symbol.type == SymDataSection ) { - auto section(symbol.elem.section); - return section.type == linkage_sect_e; - } - return false; - } ); - for( auto arg : args ) { - size_t iarg(1); - e++; // skip over linkage_sect_e, which appears after the function - if( e->type != SymField ) { - ERROR_FIELD(arg.field, - "FUNCTION %s has no defined parameter matching arg %zu, '%s'", - L->name, iarg, arg.field->name ); - return NULL; - } - - auto tgt = cbl_field_of(e); - - if( ! valid_move(tgt, arg.field) ) { - ERROR_FIELD(tgt, "FUNCTION %s arg %zu, '%s' cannot be passed to %s, type %s", - L->name, iarg, arg.field->pretty_name(), - tgt->pretty_name(), 3 + cbl_field_type_str(tgt->type) ); - return NULL; - } - } - return cbl_field_of(symbol_at(L->returning)); -} - static const struct cbl_occurs_t nonarray = cbl_occurs_t(); #if 0 @@ -317,7 +286,7 @@ class group_size_t { enum { constq = constant_e | quoted_e }; static symbol_elem_t -elementize( cbl_field_t& field ) { +elementize( const cbl_field_t& field ) { symbol_elem_t sym (SymField); sym.elem.field = field; return sym; @@ -487,9 +456,6 @@ symbol_elem_cmp( const void *K, const void *E ) case SymDataSection: return k->elem.section.type == e->elem.section.type ? 0 : 1; break; - case SymFunction: - return strcmp(k->elem.function.name, e->elem.function.name); - break; case SymField: if( has_parent(k) && cbl_field_of(k)->parent != cbl_field_of(e)->parent ) { return 1; @@ -708,7 +674,7 @@ symbol_special( size_t program, const char name[] ) struct symbol_elem_t * symbol_alphabet( size_t program, const char name[] ) { - cbl_alphabet_t alphabet(YYLTYPE(), custom_encoding_e); + cbl_alphabet_t alphabet(YYLTYPE(), custom_encoding_e); // cppcheck-suppress syntaxError assert(strlen(name) < sizeof alphabet.name); strcpy(alphabet.name, name); @@ -947,7 +913,7 @@ end_of_group( const cbl_field_t *group, const cbl_field_t *field ) { class eog_t { const cbl_field_t * group; public: - eog_t( const symbol_elem_t *e ) : group(cbl_field_of(e)) {} + explicit eog_t( const symbol_elem_t *e ) : group(cbl_field_of(e)) {} bool operator()( symbol_elem_t& e ) { return e.type == SymField && end_of_group(group, cbl_field_of(&e)); @@ -967,7 +933,7 @@ end_of_group( size_t igroup ) { if( e->program != group->program ) return isym; if( e->type == SymLabel ) return isym; // end of data division if( e->type == SymField ) { - auto f = cbl_field_of(e); + const cbl_field_t * f = cbl_field_of(e); if( f->level == LEVEL77 || f->level == 66 ) return isym; if( f->level == 1 && f->parent != igroup ) { return isym; @@ -978,7 +944,7 @@ end_of_group( size_t igroup ) { } eog_t eog(symbol_at(igroup)); - symbol_elem_t *e = std::find_if( symbols_begin(++igroup), symbols_end(), eog ); + const symbol_elem_t *e = std::find_if( symbols_begin(++igroup), symbols_end(), eog ); return e - symbols_begin(); } @@ -1033,7 +999,7 @@ symbol_find_odo_debug( cbl_field_t * field ) { // Return OCCURS DEPENDING ON table subordinate to field, if any. struct cbl_field_t * -symbol_find_odo( cbl_field_t * field ) { +symbol_find_odo( const cbl_field_t * field ) { size_t bog = field_index(field), eog = end_of_group(bog); auto e = std::find_if( symbol_at(bog), symbol_at_impl(eog, true), has_odo ); return e == symbol_at_impl(eog, true)? NULL : cbl_field_of(e); @@ -1065,10 +1031,6 @@ symbols_dump( size_t first, bool header ) { s = xasprintf("%4" GCC_PRISZ "u %-18s line %d", (fmt_size_t)e->program, cbl_section_of(e)->name(), cbl_section_of(e)->line); break; - case SymFunction: - s = xasprintf("%4" GCC_PRISZ "u %-15s %s", (fmt_size_t)e->program, - "Function", e->elem.function.name); - break; case SymField: { auto field = cbl_field_of(e); char *odo_str = NULL; @@ -1214,7 +1176,7 @@ static struct symbol_elem_t * // If an 01 record exists for the FD/SD, use its capacity as the // default_record capacity. if( p != symbols_end() ) { - auto record = cbl_field_of(p); + const cbl_field_t * record = cbl_field_of(p); assert(record->level == 1); e = calculate_capacity(p); auto record_size = std::max(record->data.memsize, @@ -1302,7 +1264,7 @@ static struct symbol_elem_t * // If group has a parent that is a record area, expand it, too. if( 0 < group->parent ) { - auto redefined = symbol_redefines(group); + redefined = symbol_redefines(group); if( redefined && is_record_area(redefined) ) { if( redefined->data.capacity < group->data.memsize ) { redefined->data.capacity = group->data.memsize; @@ -1383,19 +1345,18 @@ immediately_follows( const cbl_field_t *field ) { bool is_variable_length( const cbl_field_t *field ) { - bool odo = false; - std::find_if( symbol_at(field_index(field)) + 1, symbols_end(), - [&odo, field]( const auto& elem ) { - if( elem.type == SymField ) { - auto f = cbl_field_of(&elem); - if( f->level <= field->level ) return true; - if( f->occurs.depending_on ) { - odo = true; - return true; - } - } - return false; - } ); + // RENAMES may be included in end_of_group. + size_t isym = field_index(field), esym = end_of_group(isym); + bool odo = std::any_of( symbol_at(isym) + 1, symbol_at_impl(esym), + [field]( const auto& elem ) { + if( elem.type == SymField ) { + auto f = cbl_field_of(&elem); + if( field->level < f->level ) { // exclude RENAMES + return 0 < f->occurs.depending_on; + } + } + return false; + } ); return odo; } @@ -1407,7 +1368,7 @@ is_variable_length( const cbl_field_t *field ) { * occurs-depending table." */ cbl_field_t * -rename_not_ok( cbl_field_t *first, cbl_field_t *last) { +rename_not_ok( const cbl_field_t *first, const cbl_field_t *last) { symbol_elem_t *beg = symbol_at(field_index(first)), *end = symbol_at(field_index(last)); @@ -1475,11 +1436,11 @@ cbl_field_t::attr_str( const std::vector<cbl_field_attr_t>& attrs ) const const char *sep = ""; char *out = NULL; - for( auto attr : attrs ) { + for( auto attr_l : attrs ) { char *part = out; - if( has_attr(attr) ) { + if( has_attr(attr_l) ) { int erc = asprintf(&out, "%s%s%s", - part? part : "", sep, cbl_field_attr_str(attr)); + part? part : "", sep, cbl_field_attr_str(attr_l)); if( -1 == erc ) return part; free(part); sep = ", "; @@ -1508,7 +1469,7 @@ field_str( const cbl_field_t *field ) { } pend += snprintf(pend, string + sizeof(string) - pend, - "%02d %-20s ", field->level, name); + "%02u %-20s ", field->level, name); char offset[32] = ""; if( field->level > 1 ) { @@ -1619,7 +1580,7 @@ struct capacity_of { capacity_of operator()( symbol_elem_t& elem ) { if( elem.type == SymField ) { - cbl_field_t *f = cbl_field_of(&elem); + const cbl_field_t *f = cbl_field_of(&elem); if( is_elementary(f->type) ) { capacity += field_size(f); } @@ -1748,7 +1709,6 @@ symbols_update( size_t first, bool parsed_ok ) { case 1: pend = calculate_capacity(p); if( dialect_mf() && is_table(field) ) { - cbl_field_t *field = cbl_field_of(p); if( field->data.memsize < field->size() ) { field->data.memsize = field->size(); } @@ -1787,7 +1747,7 @@ symbols_update( size_t first, bool parsed_ok ) { bool size_invalid = field->data.memsize > 0 && symbol_redefines(field); if( size_invalid ) { // redefine of record area is ok - auto redefined = symbol_redefines(field); + const cbl_field_t * redefined = symbol_redefines(field); size_invalid = ! is_record_area(redefined); } if( !field->is_valid() || size_invalid ) @@ -1810,8 +1770,8 @@ symbols_update( size_t first, bool parsed_ok ) { if( e == symbols_end() ) { // no field redefines the file's default record auto file = cbl_file_of(symbol_at(field->parent)); - ERROR_FIELD(field, "line %d: %s lacks a file description", - file->line, file->name); + ERROR_FIELD(field, "%s lacks a file description", + file->name); return 0; } } @@ -1854,6 +1814,15 @@ symbols_update( size_t first, bool parsed_ok ) { if( field->level == 0 && field->is_key_name() ) continue; if( is_literal(field) && field->var_decl_node != NULL ) continue; + // If the field is a constant for a figconstant, just use it. + if( field->level != 0 && field->has_attr(constant_e) ) { + auto fig = cbl_figconst_field_of(field->data.initial); + if( fig ) { + field->var_decl_node = fig->var_decl_node; + continue; + } + } + if( field->is_typedef() ) { auto isym = end_of_group( symbol_index(p) ); p = symbol_at(--isym); @@ -1861,7 +1830,7 @@ symbols_update( size_t first, bool parsed_ok ) { } // Verify REDEFINing field has no ODO components - auto parent = symbol_redefines(field); + const cbl_field_t * parent = symbol_redefines(field); if( parent && !is_record_area(parent) && is_variable_length(field) ) { ERROR_FIELD(field, "line %d: REDEFINES field %s cannot be variable length", field->line, field->name); @@ -2051,15 +2020,15 @@ symbol_in_file( symbol_elem_t *e ) { } #endif -static struct cbl_field_t * -symbol_field_parent_set( struct cbl_field_t *field ) +static cbl_field_t * +symbol_field_parent_set( cbl_field_t *field ) { if( field->level == 01 ) return NULL; if( field->level == 77 ) return NULL; if( field->level == 78 ) return NULL; struct symbol_elem_t *e = symbols.elems + symbols.nelem - 1; - struct symbol_elem_t *first = symbols.elems + symbols.first_program; + const struct symbol_elem_t *first = symbols.elems + symbols.first_program; for( ; field->parent == 0 && e >= first; e-- ) { if( ! (e->type == SymField && cbl_field_of(e)->level > 0) ) { @@ -2137,7 +2106,7 @@ class parent_elem_set private: size_t parent_index; public: - parent_elem_set( size_t parent_index ) + explicit parent_elem_set( size_t parent_index ) : parent_index(parent_index) {} void operator()( struct symbol_elem_t& e ) { @@ -2213,14 +2182,22 @@ symbol_table_init(void) { } static symbol_elem_t environs[] = { + { symbol_elem_t{ 0, cbl_special_name_t{0, CONSOLE_e, "CONSOLE", 0, "/dev/stdout"}} }, // stdout in DISPLAY; stdin in ACCEPT + + { symbol_elem_t{ 0, cbl_special_name_t{0, STDIN_e, "STDIN", 0, "/dev/stdin"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, SYSIN_e, "SYSIN", 0, "/dev/stdin"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, SYSIPT_e, "SYSIPT", 0, "/dev/stdout"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, SYSIPT_e, "SYSIPT", 0, "/dev/stdin"}} }, + + { symbol_elem_t{ 0, cbl_special_name_t{0, STDOUT_e, "STDOUT", 0, "/dev/stdout"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, SYSOUT_e, "SYSOUT", 0, "/dev/stdout"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, SYSLIST_e, "SYSLIST", 0, "/dev/stdout"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, SYSLST_e, "SYSLST", 0, "/dev/stdout"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, SYSPUNCH_e, "SYSPUNCH", 0, "/dev/stderr"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, SYSPCH_e, "SYSPCH", 0, "/dev/stderr"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, CONSOLE_e, "CONSOLE", 0, "/dev/stdout"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, STDERR_e, "STDERR", 0, "/dev/stderr"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, SYSERR_e, "SYSERR", 0, "/dev/stderr"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, C01_e, "C01", 0, "/dev/null"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, C02_e, "C02", 0, "/dev/null"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, C03_e, "C03", 0, "/dev/null"}} }, @@ -2240,10 +2217,6 @@ symbol_table_init(void) { { symbol_elem_t{ 0, cbl_special_name_t{0, S04_e, "S04", 0, "/dev/null"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, S05_e, "S05", 0, "/dev/null"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, AFP_5A_e, "AFP-5A", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, STDIN_e, "STDIN", 0, "/dev/stdin"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, STDOUT_e, "STDOUT", 0, "/dev/stdout"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, STDERR_e, "STDERR", 0, "/dev/stderr"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, SYSERR_e, "SYSERR", 0, "/dev/stderr"}} }, }; struct symbol_elem_t *p = table.elems + table.nelem; @@ -2441,7 +2414,7 @@ symbol_file_add( size_t program, cbl_file_t *file ) { return NULL; } - struct symbol_elem_t sym = { SymFile, program }; + symbol_elem_t sym{ SymFile, program }; sym.elem.file = *file; e = symbol_add(&sym); @@ -2454,9 +2427,9 @@ symbol_file_add( size_t program, cbl_file_t *file ) { return e; } -struct symbol_elem_t * -symbol_alphabet_add( size_t program, struct cbl_alphabet_t *alphabet ) { - struct symbol_elem_t sym{ SymAlphabet, program }; +symbol_elem_t * +symbol_alphabet_add( size_t program, const cbl_alphabet_t *alphabet ) { + symbol_elem_t sym{ SymAlphabet, program }; sym.elem.alphabet = *alphabet; return symbol_add(&sym); } @@ -2499,7 +2472,7 @@ symbol_typedef_add( size_t program, struct cbl_field_t *field ) { auto e = symbols_end() - 1; assert( symbols_begin() < e ); if( e->type == SymField ) { - auto f = cbl_field_of(e); + const cbl_field_t * f = cbl_field_of(e); if( f == field ) return e; } @@ -2537,7 +2510,7 @@ struct symbol_elem_t * symbol_field_add( size_t program, struct cbl_field_t *field ) { field->our_index = symbols.nelem; - cbl_field_t *parent = symbol_field_parent_set( field ); + const cbl_field_t *parent = symbol_field_parent_set( field ); if( parent && parent->type == FldGroup) { // Inherit effects of parent's USAGE, as though it appeared 1st in the // member's definition. @@ -2549,7 +2522,8 @@ symbol_field_add( size_t program, struct cbl_field_t *field ) if( is_numeric(parent->usage) && parent->data.capacity > 0 ) { field->type = parent->usage; field->data = parent->data; - field->data = 0.0; + field->data = 0; // cppcheck-suppress redundantAssignment + // // cppcheck doesn't understand multiple overloaded operator= field->data.initial = NULL; } } @@ -2668,6 +2642,7 @@ symbol_field( size_t program, size_t parent, const char name[] ) return p != end? &*p : NULL; } +// cppcheck-suppress-begin [CastIntegerToAddressAtReturn] obviously not true symbol_elem_t * symbol_register( const char name[] ) { @@ -2683,6 +2658,7 @@ symbol_register( const char name[] ) return p; } +// cppcheck-suppress-end [CastIntegerToAddressAtReturn] // Find current 01 record during Level 66 construction. const symbol_elem_t * @@ -2745,11 +2721,12 @@ symbol_literalA( size_t program, const char name[] ) struct symbol_elem_t * symbol_file( size_t program, const char name[] ) { size_t nelem = symbols.nelem; - struct symbol_elem_t key = { SymFile, program }, *e = &key; + symbol_elem_t key{ SymFile, program }, *e = &key; assert(strlen(name) < sizeof(key.elem.file.name)); strcpy(key.elem.file.name, name); + // cppcheck-suppress-begin [knownConditionTrueFalse] do { e = static_cast<struct symbol_elem_t *>(lfind( &key, symbols.elems, &nelem, sizeof(*e), @@ -2758,6 +2735,7 @@ symbol_file( size_t program, const char name[] ) { key.program = cbl_label_of(symbol_at(key.program))->parent; if( key.program == 0 ) break; // no file without a program } while( !e ); + // cppcheck-suppress-end [knownConditionTrueFalse] if( e ) { assert(e->type == SymFile); @@ -2865,7 +2843,7 @@ seek_parent( const symbol_elem_t *e, size_t level ) { struct symbol_elem_t * symbol_field_same_as( cbl_field_t *tgt, const cbl_field_t *src ) { if( target_in_src(tgt, src) ) { - ERROR_FIELD(tgt, "%s %s may not reference itself as part of %s %s", + ERROR_FIELD(tgt, "%s %s may not reference itself as part of %s %s", tgt->level_str(), tgt->name, src->level_str(), src->name); return NULL; } @@ -2951,7 +2929,7 @@ symbol_file_same_record_area( std::list<cbl_file_t*>& files ) { } static symbol_elem_t * -next_program( symbol_elem_t *elem ) { +next_program( const symbol_elem_t *elem ) { size_t start = elem? symbol_index(elem) : 0; symbol_elem_t * e = std::find_if( symbols_begin(start), symbols_end(), is_program ); @@ -2989,14 +2967,14 @@ is_numeric_constant( const char name[] ) { // get default record layout for a file struct cbl_field_t * -symbol_file_record( struct cbl_file_t *file ) { +symbol_file_record( const cbl_file_t *file ) { return cbl_field_of(symbol_at(file->default_record)); } class is_section { cbl_section_type_t section_type; public: - is_section( cbl_section_type_t sect ) : section_type(sect) {} + explicit is_section( cbl_section_type_t sect ) : section_type(sect) {} bool operator()( symbol_elem_t& e ) const { return e.type == SymDataSection && cbl_section_of(&e)->type == section_type; } @@ -3007,8 +2985,6 @@ static bool fd_record_size_cmp( const symbol_elem_t& a, const symbol_elem_t& b ) return cbl_field_of(&a)->data.capacity < cbl_field_of(&b)->data.capacity; } -cbl_file_key_t cbl_file_t::no_key; - /* * Find largest and smallest record defined for a file. The rule is: * cbl_file_t::varies() returns true if the record size varies, @@ -3119,7 +3095,7 @@ cbl_alphabet_t::assign( const YYLTYPE& loc, unsigned char ch, unsigned char high return true; } auto taken = alphabet[ch]; - error_msg(loc, "ALPHABET %s, character '%c' (X'%x') " + error_msg(loc, "ALPHABET %s, character %<%c%> (X%'%x%') " "in position %d already defined at position %d", name, ISPRINT(ch)? ch : '?', ch, @@ -3168,10 +3144,9 @@ using std::deque; static deque<cbl_field_t*> stack; static cbl_field_t * -new_temporary_impl( enum cbl_field_type_t type ) +new_temporary_impl( enum cbl_field_type_t type, const cbl_name_t name = nullptr ) { extern int yylineno; - static int nstack, nliteral; static const struct cbl_field_t empty_alpha = { 0, FldAlphanumeric, FldInvalid, intermediate_e, 0, 0, 0, nonarray, 0, "", @@ -3240,11 +3215,15 @@ new_temporary_impl( enum cbl_field_type_t type ) f->line = yylineno; if( is_literal(type) ) { + static int nliteral = 0; snprintf(f->name, sizeof(f->name), "_literal%d",++nliteral); } else { + static int nstack = 0; snprintf(f->name, sizeof(f->name), "_stack%d",++nstack); } + f->data.initial = name; // capture e.g. the function name + return f; } @@ -3263,7 +3242,6 @@ parser_symbol_add2( cbl_field_t *field ) { static cbl_field_t * new_literal_add( const char initial[], uint32_t len, enum cbl_field_attr_t attr ) { - static char empty[2] = "\0"; cbl_field_t *field = NULL; if( !(attr & quoted_e) ) { @@ -3273,6 +3251,7 @@ new_literal_add( const char initial[], uint32_t len, enum cbl_field_attr_t attr } else { + static char empty[2] = "\0"; field = new_temporary_impl(FldLiteralA); field->attr |= attr; field->data.initial = len > 0? initial : empty; @@ -3367,11 +3346,11 @@ temporaries_t::reuse( cbl_field_type_t type ) { } cbl_field_t * -temporaries_t::acquire( cbl_field_type_t type ) { +temporaries_t::acquire( cbl_field_type_t type, const cbl_name_t name ) { cbl_field_t *field = reuse(type); if( !field ) { - field = new_temporary_impl(type); + field = new_temporary_impl(type, name); add(field); } return parser_symbol_add2(field); // notify of reuse @@ -3404,8 +3383,8 @@ symbol_temporaries_free() { } cbl_field_t * -new_alphanumeric( size_t capacity ) { - cbl_field_t * field = new_temporary_impl(FldAlphanumeric); +new_alphanumeric( size_t capacity, const cbl_name_t name = nullptr ) { + cbl_field_t * field = new_temporary_impl(FldAlphanumeric, name); field->data.capacity = capacity; temporaries.add(field); return parser_symbol_add2(field); @@ -3415,15 +3394,14 @@ cbl_field_t * new_temporary( enum cbl_field_type_t type, const char *initial ) { if( ! initial ) { assert( ! is_literal(type) ); // Literal type must have literal value. - return temporaries.acquire(type); + return temporaries.acquire(type, initial); } if( is_literal(type) ) { auto field = temporaries.literal(initial, type == FldLiteralA? quoted_e : none_e); return field; } - cbl_field_t *field = new_temporary_impl(type); - field->data.capacity = strlen(field->data.initial = initial); + cbl_field_t *field = new_temporary_impl(type, initial); temporaries.add(field); parser_symbol_add(field); @@ -3523,7 +3501,7 @@ cbl_field_t::internalize() { static const size_t noconv = size_t(-1); if (cd == (iconv_t)-1) { - yywarn("failed iconv_open tocode = '%s' fromcode = %s", tocode, fromcode); + yywarn("failed %<iconv_open%> tocode = %<%s%> fromcode = %s", tocode, fromcode); } bool using_assumed = fromcode == os_locale.assumed; @@ -3640,12 +3618,9 @@ cbl_label_t::explicit_parent() const { } cbl_prog_hier_t::cbl_prog_hier_t() { - nlabel = std::count_if( symbols_begin(), symbols_end(), is_program ); - assert(nlabel >0); - labels = new cbl_prog_hier_t::program_label_t[nlabel]; - std::copy_if( symbols_begin(), symbols_end(), - labels, is_program ); + std::back_inserter(labels), is_program ); + assert(! labels.empty()); } /* @@ -3738,7 +3713,8 @@ symbol_label_add( size_t program, cbl_label_t *input ) if( (e = symbol_add(&elem)) == NULL ) { cbl_errx("%s:%d: could not add '%s'", __func__, __LINE__, label->name); } - + assert(e); + common_callables_update( symbol_index(e) ); // restore munged line number unless symbol_add returned an existing label @@ -3749,39 +3725,33 @@ symbol_label_add( size_t program, cbl_label_t *input ) } /* - * Under ISO (and not IBM) Declaratives are followed by a Section name. When - * the first statement is parsed, verify, if Declaratives were used, that it + * Under ISO (and not IBM) Declaratives are followed by a Section name. If + * Declaratives were used, when the first statement is parsed verify that it * was preceeded by a Section name. */ bool -symbol_label_section_exists( size_t program ) { - auto pblob = std::find_if( symbols_begin(program), symbols_end(), - []( const auto& sym ) { - if( sym.type == SymField ) { - auto& f( sym.elem.field ); - return f.type == FldBlob; - } - return false; - } ); - if( pblob == symbols_end() ) return true; // Section name not required - - bool has_section = std::any_of( ++pblob, symbols_end(), - []( const auto& sym ) { - if( sym.type == SymLabel ) { - auto& L(sym.elem.label); - if( L.type == LblSection ) { - if( L.name[0] != '_' ) { // not implicit - return true; // Section name exists - } - } +symbol_label_section_exists( size_t eval_label_index ) { + auto eval = symbols_begin(eval_label_index); + /* cppcheck warns that the following statement depends on the order of + evaluation of side effects. Since this isn't my code, and since I don't + think the warning can be eliminated without rewriting it, I am just + supprressing it. + -- Bob Dubner, 2025-07-14 */ + // cppcheck-suppress unknownEvaluationOrder + bool has_section = std::any_of( ++eval, symbols_end(), + [program = eval->program]( const auto& sym ) { + if( program == sym.program && sym.type == SymLabel ) { + const auto& L(sym.elem.label); + // true if the symbol is an explicit label. + return L.type == LblSection && L.name[0] != '_'; } return false; } ); if( yydebug && ! has_section ) { - symbols_dump(program, true); + symbols_dump(eval_label_index, true); } - // Return true if no Declaratives, because the (non-)requirement is met. - // Return false if Declaratives exist, because no Section name was found. + // Return true if a user-defined SECTION was found after the Declaratives + // label section. return has_section; } @@ -3923,7 +3893,7 @@ expand_picture(const char *picture) { assert(strlen(picture) < PICTURE_MAX); // guaranteed by picset() in scanner size_t retval_length = PICTURE_MAX; - char *retval = (char *)xmalloc(retval_length); + char *retval = static_cast<char *>(xmalloc(retval_length)); size_t index = 0; int ch; @@ -3952,7 +3922,7 @@ expand_picture(const char *picture) if( index + repeat >= retval_length ) { retval_length <<= 1; - retval = (char *)xrealloc(retval, retval_length); + retval = static_cast<char *>(xrealloc(retval, retval_length)); } while(repeat--) @@ -3965,7 +3935,7 @@ expand_picture(const char *picture) if( index >= retval_length ) { retval_length <<= 1; - retval = (char *)xrealloc(retval, retval_length); + retval = static_cast<char *>(xrealloc(retval, retval_length)); } retval[index++] = ch; } @@ -3974,7 +3944,7 @@ expand_picture(const char *picture) if( index >= retval_length ) { retval_length <<= 1; - retval = (char *)xrealloc(retval, retval_length); + retval = static_cast<char *>(xrealloc(retval, retval_length)); } retval[index++] = '\0'; @@ -3997,7 +3967,6 @@ expand_picture(const char *picture) { pcurrency[i] = 'B'; } - dest_length += sign_length; } } @@ -4228,7 +4197,7 @@ symbol_program_callables( size_t program ) { if( e->type != SymLabel ) continue; if( e->elem.label.type != LblProgram ) continue; - auto prog = cbl_label_of(e); + const cbl_label_t * prog = cbl_label_of(e); if( program == symbol_index(e) && !prog->recursive ) continue; if( (self->parent == prog->parent && prog->common) || @@ -4262,6 +4231,7 @@ symbol_program_local( const char tgt_name[] ) { */ std::map<char, const char *> currencies; +// cppcheck-suppress-begin [nullPointerRedundantCheck] bool symbol_currency_add( const char symbol[], const char sign[] ) { // In service of CURRENCY sign PICTURE SYMBOL symbol @@ -4273,6 +4243,7 @@ symbol_currency_add( const char symbol[], const char sign[] ) { currencies[*symbol] = sign; return true; } +// cppcheck-suppress-end [nullPointerRedundantCheck] const char * symbol_currency( char sign ) { @@ -4280,6 +4251,11 @@ symbol_currency( char sign ) { if( currencies.size() == 0 ) { currencies['$'] = "$"; } + if( sign == '\0' ) { // default + auto result = currencies.begin(); + gcc_assert(result != currencies.end()); + return result->second; + } auto result = currencies.find(sign); return result == currencies.end()? NULL : result->second; } @@ -4295,24 +4271,19 @@ bool decimal_is_comma() { return decimal_point == ','; } /* * A cbl_occurs_key_t is part of a field definition, and comprises * size_t symbol indexes. A cbl_key_t is a list of field pointers, - * and can be created ad hoc to describe a sort. We can construct a + * and can be created ad hoc to describe a sort. We construct a * cbl_key_t from cbl_occurs_key_t. */ cbl_key_t:: cbl_key_t( const cbl_occurs_key_t& that ) : ascending(that.ascending) { - if( that.field_list.nfield == 0 ) { - *this = cbl_key_t(); - return; - } - - nfield = that.field_list.nfield; - fields = static_cast<cbl_field_t**>( xcalloc(nfield, - sizeof(*fields)) ); - for( size_t i=0; i < that.field_list.nfield; i++ ) { - fields[i] = cbl_field_of(symbol_at(that.field_list.fields[i])); - } + std::transform( that.field_list.fields, + that.field_list.fields + that.field_list.nfield, + std::back_inserter(fields), + []( size_t isym ) { + return cbl_field_of(symbol_at(isym)); + } ); } void @@ -4325,7 +4296,7 @@ cbl_occurs_t::key_alloc( bool ascending ) { } void -cbl_occurs_t::field_add( cbl_field_list_t& field_list, cbl_field_t *field ) { +cbl_occurs_t::field_add( cbl_field_list_t& field_list, const cbl_field_t *field ) { cbl_field_list_t list = field_list; size_t ifield = field_index(field); auto nbytes = sizeof(list.fields[0]) * (list.nfield + 1); @@ -4343,14 +4314,14 @@ cbl_occurs_t::key_field_add( cbl_field_t *field ) { } void -cbl_occurs_t::index_add( cbl_field_t *field ) { +cbl_occurs_t::index_add( const cbl_field_t *field ) { field_add(indexes, field); } class is_field_at { cbl_field_t *field; public: - is_field_at( cbl_field_t *field ) : field(field) {} + explicit is_field_at( cbl_field_t *field ) : field(field) {} bool operator()( size_t isym ) const { return field == field_at(isym); } @@ -4393,6 +4364,26 @@ cbl_occurs_t::subscript_ok( const cbl_field_t *subscript ) const { return bounds.lower <= (size_t)sub && (size_t)sub <= bounds.upper; } +const cbl_field_t * +symbol_unresolved_file_key( const cbl_file_t * file, + const cbl_name_t key_field_name ) { + const symbol_elem_t *file_sym = symbol_elem_of(file); + size_t program = file_sym->program; + for( const symbol_elem_t *e = file_sym - 1; e->program == program; e-- ) { + if( e->type == SymFile ) break; + if( e->type == SymField ) { + auto f = cbl_field_of(e); + if( f->type == FldLiteralA ) break; + if( f->type == FldForward ) { + if( 0 == strcmp(key_field_name, f->name) ) { + return f; + } + } + } + } + return nullptr; +} + cbl_file_key_t:: cbl_file_key_t( cbl_name_t name, const std::list<cbl_field_t *>& fields, @@ -4518,11 +4509,11 @@ cbl_file_key_t::deforward( size_t ifile ) { const auto file = cbl_file_of(symbol_at(ifile)); std::transform( fields, fields + nfield, fields, [ifile, file]( size_t fwd ) { - static std::map<size_t, int> keys; auto ifield = symbol_forward_to(fwd); const auto field = cbl_field_of(symbol_at(ifield)); if( is_forward(field) && yydebug ) { + static std::map<size_t, int> keys; dbgmsg("%s:%d: key %d: #" HOST_SIZE_T_PRINT_UNSIGNED " %s of %s is %s", "deforward", __LINE__, keys[ifile]++, (fmt_size_t)ifield, field->name, file->name, @@ -4534,7 +4525,7 @@ cbl_file_key_t::deforward( size_t ifile ) { if( ifield == fwd ) { ERROR_FIELD(field, "line %d: %s of %s " "is not defined", - file->line, field->name, file->name); + field->line, field->name, file->name); return ifield; } @@ -4563,9 +4554,13 @@ cbl_file_key_t::deforward( size_t ifile ) { // looked-up field must have same file as parent if( ! (parent != NULL && symbol_index(symbol_elem_of(parent)) == ifile) ) { - ERROR_FIELD(field, "line %d: %s of %s " - "is not defined in file description", - file->line, field->name, file->name); + const cbl_field_t *undefined = + symbol_unresolved_file_key(file, field->name); + int lineno = undefined? undefined->line : file->line; + ERROR_FIELD(undefined? undefined : field, + "line %d: %s of %s " + "is not defined in file description", + lineno, field->name, file->name); } return ifield; } ); @@ -4609,27 +4604,12 @@ cbl_file_t::deforward() { char * cbl_file_t::keys_str() const { - std::vector <char *> ks(nkey); - std::transform(keys, keys + nkey, ks.begin(), - []( const cbl_file_key_t& key ) { - return key.str(); - } ); - size_t n = 4 * nkey + std::accumulate(ks.begin(), ks.end(), 0, - []( int n, const char *s ) { - return n + strlen(s); - } ); - char *output = static_cast<char*>( xcalloc(1, n) ), *p = output; - const char *sep = ""; - - *p++ = '['; - for( auto k : ks ) { - p = stpcpy(p, sep); - p = stpcpy(p, k); - sep = ", "; - free(k); + std::string names = "["; + for( cbl_file_key_t *p = keys; p < keys + nkey; p++ ) { + names += p->str(); + names += p + 1 < keys + nkey ? "," : "]"; } - *p++ = ']'; - return output; + return xasprintf("%s", names.c_str()); } /* @@ -4691,11 +4671,13 @@ cbl_file_status_cmp( const void *K, const void *E ) { static long file_status_status_of( file_status_t status ) { size_t n = COUNT_OF(file_status_fields); - file_status_field_t *fs, key { status }; - - fs = (file_status_field_t*)lfind( &key, file_status_fields, - &n, sizeof(*fs), cbl_file_status_cmp ); + const file_status_field_t *fs, key { status }; + fs = static_cast<file_status_field_t*>(lfind( &key, + file_status_fields, + &n, + sizeof(*fs), + cbl_file_status_cmp )); return fs? (long)fs->status : -1; } @@ -4721,7 +4703,7 @@ ast_file_status_between( file_status_t lower, file_status_t upper ) { } bool -is_register_field(cbl_field_t *field) +is_register_field(const cbl_field_t *field) { // TRUE when the field is an executable-level global variable of the type we // are calling a "register", like RETURN-CODE or UPSI or the like: diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h index e272907..c8ae32f 100644 --- a/gcc/cobol/symbols.h +++ b/gcc/cobol/symbols.h @@ -32,11 +32,11 @@ #else #define _SYMBOLS_H_ -#include <assert.h> -#include <limits.h> -#include <stdint.h> -#include <stdlib.h> -#include <string.h> +#include <cassert> +#include <climits> +#include <cstdint> +#include <cstdlib> +#include <cstring> #include <algorithm> #include <list> @@ -46,11 +46,6 @@ #include <string> #include <vector> -// Provide fallback definition. -#ifndef NAME_MAX -#define NAME_MAX 255 -#endif - #define PICTURE_MAX 64 extern const char *numed_message; @@ -62,19 +57,22 @@ enum cbl_dialect_t { dialect_gnu_e = 0x04, }; -extern cbl_dialect_t cbl_dialect; +// Dialects may be combined. +extern unsigned int cbl_dialects; void cobol_dialect_set( cbl_dialect_t dialect ); -cbl_dialect_t dialect_is(); +// GCC dialect means no other dialects static inline bool dialect_gcc() { - return dialect_gcc_e == cbl_dialect; + return dialect_gcc_e == cbl_dialects; } - static inline bool dialect_ibm() { - return dialect_ibm_e == (cbl_dialect & dialect_ibm_e); + return dialect_ibm_e == (cbl_dialects & dialect_ibm_e); } static inline bool dialect_mf() { - return dialect_mf_e == (cbl_dialect & dialect_mf_e ); + return dialect_mf_e == (cbl_dialects & dialect_mf_e ); +} +static inline bool dialect_gnu() { + return dialect_gnu_e == (cbl_dialects & dialect_gnu_e ); } enum cbl_gcobol_feature_t { @@ -133,13 +131,13 @@ is_numeric( cbl_field_type_t type ) { case FldIndex: return true; } - yywarn( "%s:%d: invalid symbol_type_t %d", __func__, __LINE__, type ); + cbl_internal_error( "%s:%d: invalid %<symbol_type_t%> %d", __func__, __LINE__, type ); return false; } struct os_locale_t { char assumed[16]; - char *codeset; + const char *codeset; }; const char * cbl_field_attr_str( cbl_field_attr_t attr ); @@ -151,6 +149,7 @@ is_working_storage(uint32_t attr) { return 0 == (attr & (linkage_e | local_e)); } +int cbl_figconst_tok( const char *value ); enum cbl_figconst_t cbl_figconst_of( const char *value ); const char * cbl_figconst_str( cbl_figconst_t fig ); @@ -174,7 +173,7 @@ class cbl_domain_elem_t { { if( value && ! is_numeric ) { auto s = consistent_encoding_check(loc, value); - if( s ) value = s; + if( s ) this->value = s; } } const char *name() const { return value; } @@ -220,7 +219,6 @@ bool decimal_is_comma(); enum symbol_type_t { SymFilename, - SymFunction, SymField, SymLabel, // section, paragraph, or label SymSpecial, @@ -266,7 +264,18 @@ struct cbl_field_data_t { explicit etc_t( tree v = build_zero_cst (float128_type_node)) : value(v) {} } etc; - cbl_field_data_t( uint32_t memsize=0, uint32_t capacity=0 ) + cbl_field_data_t() + : memsize(0) + , capacity(0) + , digits(0) + , rdigits(0) + , initial(0) + , picture(0) + , etc_type(value_e) + , etc() + {} + + cbl_field_data_t( uint32_t memsize, uint32_t capacity ) : memsize(memsize) , capacity(capacity) , digits(0) @@ -329,6 +338,10 @@ struct cbl_field_data_t { etc_type = value_e; return etc.value = v; } + tree& operator=(int i) { + etc_type = value_e; + return etc.value = build_int_cst_type(integer_type_node, i); + } void set_real_from_capacity( REAL_VALUE_TYPE *r ) const { real_from_integer (r, VOIDmode, capacity, SIGNED); @@ -414,8 +427,11 @@ struct cbl_occurs_bounds_t { // variable size table. lower can be zero. size_t lower, upper; - cbl_occurs_bounds_t(size_t lower=0, size_t upper=0) + cbl_occurs_bounds_t() + : lower(0), upper(0) {} + explicit cbl_occurs_bounds_t(size_t lower, size_t upper=0) : lower(lower), upper(upper) {} + size_t ntimes() const { return upper; } @@ -448,12 +464,12 @@ struct cbl_occurs_t { void key_alloc( bool ascending ); void key_field_add( cbl_field_t *field ); - void index_add( cbl_field_t *field ); + void index_add( const cbl_field_t *field ); cbl_occurs_key_t * key_of( cbl_field_t *field ); bool subscript_ok( const cbl_field_t *subscript ) const; protected: - void field_add( cbl_field_list_t& fields, cbl_field_t *field ); + void field_add( cbl_field_list_t& fields, const cbl_field_t *field ); }; /* @@ -634,6 +650,8 @@ struct cbl_field_t { } }; +const cbl_field_t * cbl_figconst_field_of( const char *value ); + // Necessary forward referencea struct cbl_label_t; struct cbl_refer_t; @@ -641,7 +659,7 @@ struct cbl_refer_t; struct cbl_span_t { cbl_refer_t *from, *len; - cbl_span_t( cbl_refer_t *from, cbl_refer_t *len = NULL ) + explicit cbl_span_t( cbl_refer_t *from, cbl_refer_t *len = NULL ) : from(from), len(len) {}; bool is_active() const { return !( from == NULL && len == NULL ); } @@ -655,50 +673,64 @@ struct cbl_refer_t { cbl_field_t *field; cbl_label_t *prog_func; bool all, addr_of; - uint32_t nsubscript; - cbl_refer_t *subscripts; // indices + std::vector<cbl_refer_t> subscripts; // indices cbl_span_t refmod; // substring bounds cbl_refer_t() - : field(NULL), prog_func(NULL) + : loc(), field(NULL), prog_func(NULL) , all(NULL), addr_of(false) - , nsubscript(0), subscripts(NULL), refmod(NULL) + , refmod(NULL) {} + // cppcheck-suppress noExplicitConstructor cbl_refer_t( cbl_field_t *field, bool all = false ) - : field(field), prog_func(NULL) + : loc(), field(field), prog_func(NULL) , all(all), addr_of(false) - , nsubscript(0), subscripts(NULL), refmod(NULL) + , refmod(NULL) {} cbl_refer_t( const YYLTYPE& loc, cbl_field_t *field, bool all = false ) : loc(loc), field(field), prog_func(NULL) , all(all), addr_of(false) - , nsubscript(0), subscripts(NULL), refmod(NULL) + , refmod(NULL) {} cbl_refer_t( cbl_field_t *field, cbl_span_t& refmod ) - : field(field), prog_func(NULL) + : loc(), field(field), prog_func(NULL) , all(false), addr_of(false) - , nsubscript(0), subscripts(NULL), refmod(refmod) + , refmod(refmod) {} cbl_refer_t( cbl_field_t *field, - size_t nsubscript, cbl_refer_t *subscripts, + const std::vector<cbl_refer_t>& subscripts, cbl_span_t refmod = cbl_span_t(NULL) ) - : field(field), prog_func(NULL) + : loc(), field(field), prog_func(NULL) , all(false), addr_of(false) - , nsubscript(nsubscript) , subscripts( new cbl_refer_t[nsubscript] ) + , subscripts(subscripts) , refmod(refmod) - { - std::copy(subscripts, subscripts + nsubscript, this->subscripts); - } + {} explicit cbl_refer_t( cbl_label_t *prog_func, bool addr_of = true ) - : field(NULL), prog_func(prog_func) + : loc(), field(NULL), prog_func(prog_func) , all(false), addr_of(addr_of) - , nsubscript(0), subscripts(NULL), refmod(cbl_span_t(NULL)) + , refmod(cbl_span_t(NULL)) {} + cbl_refer_t( const cbl_refer_t& that ) = default; + + cbl_refer_t& operator=( const cbl_refer_t& that ) { + loc = that.loc; + field = that.field; + prog_func = that.prog_func; + all = that.all; + addr_of = that.addr_of; + subscripts = that.subscripts; + refmod = that.refmod; + return *this; + } + + cbl_refer_t duplicate() const { - return cbl_refer_t( field, nsubscript, subscripts, refmod ); + return cbl_refer_t( field, subscripts, refmod ); } + uint32_t nsubscript() const { return subscripts.size(); } + static cbl_refer_t *empty(); cbl_refer_t * name( const char name[] ) { @@ -709,8 +741,8 @@ struct cbl_refer_t { } bool is_pointer() const { return addr_of || field->type == FldPointer; } - bool is_reference() const { return nsubscript > 0 || refmod.is_active(); } - bool is_table_reference() const { return nsubscript > 0; } + bool is_reference() const { return nsubscript() > 0 || refmod.is_active(); } + bool is_table_reference() const { return nsubscript() > 0; } bool is_refmod_reference() const { return refmod.is_active(); } size_t subscripts_set( const std::list<cbl_refer_t>& subs ); @@ -775,7 +807,7 @@ struct field_key_t { } }; -bool valid_move( const struct cbl_field_t *tgt, const struct cbl_field_t *src ); +bool valid_move( const cbl_field_t *tgt, const cbl_field_t *src ); #define record_area_name_stem "_ra_" @@ -785,8 +817,7 @@ is_record_area( const cbl_field_t *field ) { return 0 == memcmp(field->name, stem, sizeof(stem)-1); } -bool -is_register_field(cbl_field_t *field); +bool is_register_field( const cbl_field_t *field ); static inline bool is_constant( const cbl_field_t *field ) { @@ -804,17 +835,20 @@ symbol_field_type_update( cbl_field_t *field, cbl_field_type_t type, bool is_usage ); struct sort_key_t; +struct sort_key_t; struct cbl_key_t { bool ascending; - size_t nfield; - cbl_field_t **fields; + std::vector<const cbl_field_t*> fields; - cbl_key_t() : ascending(false), nfield(0), fields(0) {} - cbl_key_t( size_t nfield, cbl_field_t **fields, bool ascending = true ) - : ascending(ascending), nfield(nfield), fields(fields) {} - cbl_key_t( const sort_key_t& src ); + cbl_key_t() : ascending(true) {} + explicit cbl_key_t( sort_key_t src ); explicit cbl_key_t( const cbl_occurs_key_t& that ); + cbl_key_t( size_t nfield, cbl_field_t **fields, bool ascending = true ) + : ascending(ascending) + , fields(fields, fields + nfield) + {} + cbl_key_t& operator=( const sort_key_t& that ); }; enum cbl_label_type_t { @@ -911,8 +945,12 @@ struct cbl_substitute_t { subst_fl_t first_last; cbl_refer_t orig, replacement; - cbl_substitute_t( bool anycase = false, char first_last = 0, - cbl_refer_t *orig = NULL, cbl_refer_t *replacement = NULL ) + cbl_substitute_t() + : anycase(false) + , first_last(subst_all_e) + {} + cbl_substitute_t( bool anycase, char first_last, + cbl_refer_t *orig, cbl_refer_t *replacement ) : anycase(anycase) , first_last(subst_fl_t(first_last)) , orig( orig? *orig : cbl_refer_t() ) @@ -945,7 +983,10 @@ struct cbl_num_result_t { enum cbl_round_t rounded; struct cbl_refer_t refer; - static cbl_refer_t refer_of( const cbl_num_result_t& res ) { return res.refer; } + static const cbl_refer_t& + refer_of( const cbl_num_result_t& res ) { + return res.refer; + } }; void parser_symbol_add( struct cbl_field_t *new_var ); @@ -957,8 +998,9 @@ struct cbl_ffi_arg_t { cbl_ffi_arg_attr_t attr; cbl_refer_t refer; // refer::field == NULL is OMITTED - cbl_ffi_arg_t( cbl_refer_t* refer = NULL, - cbl_ffi_arg_attr_t attr = none_of_e ); + cbl_ffi_arg_t(); + cbl_ffi_arg_t( cbl_refer_t* refer, + cbl_ffi_arg_attr_t attr ); cbl_ffi_arg_t( cbl_ffi_crv_t crv, cbl_refer_t* refer, cbl_ffi_arg_attr_t attr = none_of_e ); @@ -1171,8 +1213,11 @@ class temporaries_t { struct literal_an { bool is_quoted; std::string value; - literal_an( const char value[] = "???", bool is_quoted = false ) + literal_an() : is_quoted(false), value("???") {} + literal_an( const char value[], bool is_quoted ) : is_quoted(is_quoted), value(value) {} + literal_an( const literal_an& that ) + : is_quoted(that.is_quoted), value(that.value) {} literal_an& operator=( const literal_an& that ) { is_quoted = that.is_quoted; value = that.value; @@ -1194,7 +1239,7 @@ class temporaries_t { public: cbl_field_t * literal( const char value[], uint32_t len, cbl_field_attr_t attr = none_e ); cbl_field_t * reuse( cbl_field_type_t type ); - cbl_field_t * acquire( cbl_field_type_t type ); + cbl_field_t * acquire( cbl_field_type_t type, const cbl_name_t name = nullptr ); cbl_field_t * add( cbl_field_t *field ); bool keep( cbl_field_t *field ) { return 1 == used[field->type].erase(field); } void dump() const; @@ -1419,10 +1464,10 @@ struct cbl_alphabet_t { add_sequence( const YYLTYPE& loc, const unsigned char seq[] ) { if( low_index == 0 ) low_index = seq[0]; - unsigned char high_value = last_index > 0? alphabet[last_index] + 1 : 0; + unsigned char last = last_index > 0? alphabet[last_index] + 1 : 0; for( const unsigned char *p = seq; !end_of_string(p); p++ ) { - assign(loc, *p, high_value++); + assign(loc, *p, last++); } } @@ -1430,10 +1475,10 @@ struct cbl_alphabet_t { add_interval( const YYLTYPE& loc, unsigned char low, unsigned char high ) { if( low_index == 0 ) low_index = low; - unsigned char high_value = alphabet[last_index]; + unsigned char last = alphabet[last_index]; for( unsigned char ch = low; ch < high; ch++ ) { - assign(loc, ch, high_value++); + assign(loc, ch, last++); } } @@ -1452,7 +1497,7 @@ struct cbl_alphabet_t { } void dump() const { - yywarn("'%s': %s, '%c' to '%c' (low 0x%02x, high 0x%02x)", + yywarn("%qs: %s, %<%c%> to %<%c%> (low 0x%x, high 0x%x)", name, encoding_str(encoding), low_index, last_index, low_index, high_index); if( encoding == custom_encoding_e ) { @@ -1475,14 +1520,6 @@ struct cbl_alphabet_t { } }; -// a function pointer -typedef void ( *cbl_function_ptr ) ( void ); - -struct cbl_function_t { - char name[NAME_MAX]; - cbl_function_ptr func; -}; - static inline const char * file_org_str( enum cbl_file_org_t org ) { switch ( org ) { @@ -1521,9 +1558,19 @@ struct cbl_file_key_t { cbl_name_t name; size_t leftmost; // START or READ named leftmost field in key size_t nfield; - size_t *fields; + size_t *fields; // cppcheck-suppress unsafeClassCanLeak - cbl_file_key_t( size_t field = 0, bool unique = true ) + cbl_file_key_t() + : unique(true) + , leftmost(0) + , nfield(0) + , fields(nullptr) + { + memset(name, '\0', sizeof(name)); + } + + // Construct a key of length 1 having a single field. + explicit cbl_file_key_t( size_t field, bool unique = true ) : unique(unique) , leftmost(0) , nfield(1) @@ -1532,20 +1579,34 @@ struct cbl_file_key_t { fields[0] = field; memset(name, '\0', sizeof(name)); } - cbl_file_key_t( const cbl_file_key_t *that ) - : unique(that->unique) - , leftmost(that->leftmost) - , nfield(that->nfield) - { - memcpy(name, that->name, sizeof(name)); - fields = new size_t[nfield]; - std::copy( that->fields, that->fields + that->nfield, fields ); - } cbl_file_key_t( cbl_name_t name, const std::list<cbl_field_t *>& fields, bool is_unique ); + // The copy constructor and assignment operator exist to quell reports from + // cppcheck. When these objects are copied, the copy still points to the + // original data. + cbl_file_key_t( const cbl_file_key_t& that ) + : unique(that.unique) + , leftmost(that.leftmost) + , nfield(that.nfield) + // cppcheck-suppress copyCtorPointerCopying + , fields(that.fields) + { + strcpy(name, that.name); + } + ~cbl_file_key_t() {} + cbl_file_key_t& operator=( const cbl_file_key_t& that ) { + unique = that.unique; + leftmost = that.leftmost; + nfield = that.nfield; + // cppcheck-suppress copyCtorPointerCopying + fields = that.fields; + strcpy(name, that.name); + return *this; + } + uint32_t size(); void deforward( size_t ifile ); char * str() const; @@ -1559,12 +1620,12 @@ struct cbl_file_key_t { struct cbl_file_lock_t { bool multiple; enum lock_mode_t { unlocked_e, manual_e, record_e, automatic_e } mode; + cbl_file_lock_t() : multiple(false), mode(unlocked_e) {} bool mode_set( int token ); bool locked() const { return mode != unlocked_e; } }; struct cbl_file_t { - static cbl_file_key_t no_key; enum cbl_file_org_t org; enum file_entry_type_t entry_type; uint32_t attr; @@ -1591,15 +1652,32 @@ struct cbl_file_t { tree var_decl_node; // GENERIC tag for the run-time FIELD structure cbl_file_t() - : org(file_disorganized_e), - access(file_access_seq_e) + : org(file_disorganized_e) + , entry_type(fd_e) + , attr(0), reserve(0), same_record_as(0) + , padding('\0') + , optional(false) + , varying_size{ false, 0, 0 } + , access(file_access_seq_e) + , filename(0) + , default_record(0) + , nkey(0) + , keys(nullptr) + , password(0), user_status(0), vsam_status(0), record_length(0) + , line(0) + , addresses(nullptr) + , var_decl_node(nullptr) { - keys = &no_key; + memset(name, '\0', sizeof(name)); } bool varies() const { return varying_size.min != varying_size.max; } bool validate() const; void deforward(); + cbl_file_key_t * keys_update( cbl_file_key_t * keys ) { + if( this->keys ) delete[] this->keys; + return this->keys = keys; + } char * keys_str() const; int key_one( cbl_field_t *field ) const { auto ekey = keys + nkey, p = ekey; @@ -1638,20 +1716,17 @@ struct symbol_elem_t { size_t program; union symbol_elem_u { char *filename; - cbl_function_t function; cbl_field_t field; cbl_label_t label; cbl_special_name_t special; cbl_alphabet_t alphabet; cbl_file_t file; cbl_section_t section; - symbol_elem_u() { - static const cbl_field_t empty = {}; - field = empty; - } + symbol_elem_u() : field() {} } elem; - symbol_elem_t( symbol_type_t type = SymField, size_t program = 0 ) + symbol_elem_t() : type(SymField), program(0) {} + explicit symbol_elem_t( symbol_type_t type, size_t program = 0 ) : type(type), program(program) {} @@ -1692,9 +1767,6 @@ struct symbol_elem_t { case SymFilename: elem.filename = that.elem.filename; break; - case SymFunction: - elem.function = that.elem.function; - break; case SymField: elem.field = that.elem.field; break; @@ -1724,6 +1796,7 @@ static inline symbol_elem_t * symbol_elem_of( cbl_label_t *label ) { size_t n = offsetof(struct symbol_elem_t, elem.label); return + // cppcheck-suppress cstyleCast reinterpret_cast<struct symbol_elem_t *>((char*)label - n); } @@ -1731,6 +1804,7 @@ static inline const symbol_elem_t * symbol_elem_of( const cbl_label_t *label ) { size_t n = offsetof(symbol_elem_t, elem.label); return + // cppcheck-suppress cstyleCast reinterpret_cast<const symbol_elem_t *>((const char*)label - n); } @@ -1738,6 +1812,7 @@ static inline symbol_elem_t * symbol_elem_of( cbl_special_name_t *special ) { size_t n = offsetof(symbol_elem_t, elem.special); return + // cppcheck-suppress cstyleCast reinterpret_cast<symbol_elem_t *>((char*)special - n); } @@ -1745,6 +1820,7 @@ static inline symbol_elem_t * symbol_elem_of( cbl_alphabet_t *alphabet ) { size_t n = offsetof(symbol_elem_t, elem.alphabet); return + // cppcheck-suppress cstyleCast reinterpret_cast<symbol_elem_t *>((char*)alphabet - n); } @@ -1752,12 +1828,14 @@ static inline symbol_elem_t * symbol_elem_of( cbl_file_t *file ) { size_t n = offsetof(struct symbol_elem_t, elem.file); return + // cppcheck-suppress cstyleCast reinterpret_cast<struct symbol_elem_t *>((char*)file - n); } static inline const symbol_elem_t * symbol_elem_of( const cbl_file_t *file ) { size_t n = offsetof(symbol_elem_t, elem.file); return + // cppcheck-suppress cstyleCast reinterpret_cast<const symbol_elem_t *>((const char*)file - n); } @@ -1765,18 +1843,20 @@ static inline symbol_elem_t * symbol_elem_of( cbl_field_t *field ) { size_t n = offsetof(struct symbol_elem_t, elem.field); return + // cppcheck-suppress cstyleCast reinterpret_cast<struct symbol_elem_t *>((char*)field - n); } static inline const symbol_elem_t * symbol_elem_of( const cbl_field_t *field ) { size_t n = offsetof(symbol_elem_t, elem.field); return + // cppcheck-suppress cstyleCast reinterpret_cast<const symbol_elem_t *>((const char*)field - n); } symbol_elem_t * symbols_begin( size_t first = 0 ); symbol_elem_t * symbols_end(void); -cbl_field_t * symbol_redefines( const struct cbl_field_t *field ); +cbl_field_t * symbol_redefines( const cbl_field_t *field ); void build_symbol_map(); bool update_symbol_map( symbol_elem_t *e ); @@ -1792,7 +1872,7 @@ symbol_find( size_t program, std::list<const char *> names ); symbol_elem_t * symbol_find_of( size_t program, std::list<const char *> names, size_t group ); -struct cbl_field_t *symbol_find_odo( cbl_field_t * field ); +struct cbl_field_t *symbol_find_odo( const cbl_field_t * field ); size_t dimensions( const cbl_field_t *field ); const symbol_elem_t * symbol_field_current_record(); @@ -1814,63 +1894,60 @@ const cbl_label_t * symbol_program_local( const char called[] ); bool redefine_field( cbl_field_t *field ); -// Functions to correctly extract the underlying type. -static inline struct cbl_function_t * -cbl_function_of( struct symbol_elem_t *e ) { - assert(e->type == SymFunction); - return &e->elem.function; -} +const cbl_field_t * +symbol_unresolved_file_key( const cbl_file_t * file, + const cbl_name_t key_field_name ); static inline struct cbl_section_t * cbl_section_of( struct symbol_elem_t *e ) { - assert(e->type == SymDataSection); + assert(e && e->type == SymDataSection); return &e->elem.section; } static inline struct cbl_field_t * cbl_field_of( struct symbol_elem_t *e ) { - assert(e->type == SymField); + assert(e && e->type == SymField); return &e->elem.field; } -static inline const struct cbl_field_t * -cbl_field_of( const struct symbol_elem_t *e ) { - assert(e->type == SymField); +static inline const cbl_field_t * +cbl_field_of( const symbol_elem_t *e ) { + assert(e && e->type == SymField); return &e->elem.field; } static inline struct cbl_label_t * cbl_label_of( struct symbol_elem_t *e ) { - assert(e->type == SymLabel); + assert(e && e->type == SymLabel); return &e->elem.label; } -static inline const struct cbl_label_t * -cbl_label_of( const struct symbol_elem_t *e ) { - assert(e->type == SymLabel); +static inline const cbl_label_t * +cbl_label_of( const symbol_elem_t *e ) { + assert(e && e->type == SymLabel); return &e->elem.label; } static inline struct cbl_special_name_t * cbl_special_name_of( struct symbol_elem_t *e ) { - assert(e->type == SymSpecial); + assert(e && e->type == SymSpecial); return &e->elem.special; } static inline struct cbl_alphabet_t * cbl_alphabet_of( struct symbol_elem_t *e ) { - assert(e->type == SymAlphabet); + assert(e && e->type == SymAlphabet); return &e->elem.alphabet; } static inline struct cbl_file_t * cbl_file_of( struct symbol_elem_t *e ) { - assert(e->type == SymFile); + assert(e && e->type == SymFile); return &e->elem.file; } -static inline const struct cbl_file_t * -cbl_file_of( const struct symbol_elem_t *e ) { - assert(e->type == SymFile); +static inline const cbl_file_t * +cbl_file_of( const symbol_elem_t *e ) { + assert(e && e->type == SymFile); return &e->elem.file; } @@ -1889,43 +1966,43 @@ is_procedure( const symbol_elem_t& e ) { } static inline bool -is_figconst(const struct cbl_field_t *field ) { - return ((field->attr & FIGCONST_MASK) != 0 ); +is_figconst(const cbl_field_t *field ) { + return (field->attr & FIGCONST_MASK) != 0; } static inline bool -is_figconst_low( const struct cbl_field_t *field ) { - return ((field->attr & FIGCONST_MASK) == low_value_e ); +is_figconst_low( const cbl_field_t *field ) { + return (field->attr & FIGCONST_MASK) == low_value_e; } static inline bool -is_figconst_zero( const struct cbl_field_t *field ) { - return ((field->attr & FIGCONST_MASK) == zero_value_e ); +is_figconst_zero( const cbl_field_t *field ) { + return (field->attr & FIGCONST_MASK) == zero_value_e; } static inline bool -is_figconst_space( const struct cbl_field_t *field ) { - return ((field->attr & FIGCONST_MASK) == space_value_e ); +is_figconst_space( const cbl_field_t *field ) { + return (field->attr & FIGCONST_MASK) == space_value_e; } static inline bool -is_figconst_quote( const struct cbl_field_t *field ) { - return ((field->attr & FIGCONST_MASK) == quote_value_e ); +is_figconst_quote( const cbl_field_t *field ) { + return (field->attr & FIGCONST_MASK) == quote_value_e; } static inline bool -is_figconst_high( const struct cbl_field_t *field ) { - return ((field->attr & FIGCONST_MASK) == high_value_e ); +is_figconst_high( const cbl_field_t *field ) { + return (field->attr & FIGCONST_MASK) == high_value_e; } static inline bool -is_space_value( const struct cbl_field_t *field ) { - return( (strcmp(field->name, "SPACE") == 0) - || (strcmp(field->name, "SPACES") == 0) ); +is_space_value( const cbl_field_t *field ) { + return (strcmp(field->name, "SPACE") == 0) + || (strcmp(field->name, "SPACES") == 0); } static inline bool -is_quoted( const struct cbl_field_t *field ) { +is_quoted( const cbl_field_t *field ) { return field->has_attr(quoted_e); } @@ -1945,7 +2022,7 @@ struct cbl_until_addresses_t { struct cbl_label_addresses_t test; // The test at the bottom of the body struct cbl_label_addresses_t testA; // Starting point of a TEST_AFTER loop struct cbl_label_addresses_t setup; // The actual entry point - size_t number_of_conditionals; + unsigned int number_of_conditionals; struct cbl_label_addresses_t condover[MAXIMUM_UNTILS]; // Jumping over the conditional struct cbl_label_addresses_t condinto[MAXIMUM_UNTILS]; // Jumping into the conditional struct cbl_label_addresses_t condback[MAXIMUM_UNTILS]; // Jumping back from the conditional @@ -1953,7 +2030,7 @@ struct cbl_until_addresses_t { }; size_t symbol_index(); // nth after first program symbol -size_t symbol_index( const struct symbol_elem_t *e ); +size_t symbol_index( const symbol_elem_t *e ); struct symbol_elem_t * symbol_at( size_t index ); struct cbl_options_t { @@ -2005,17 +2082,20 @@ symbol_field_forward_add( size_t program, size_t parent, struct cbl_field_t * symbol_field_forward( size_t index ); struct cbl_prog_hier_t { - size_t nlabel; struct program_label_t { size_t ordinal; cbl_label_t label; - program_label_t() : ordinal(0) {} - program_label_t( const symbol_elem_t& e ) { + program_label_t() : ordinal(0), label() {} + // because std::copy_if: + // cppcheck-suppress noExplicitConstructor + program_label_t( const symbol_elem_t& e ) { + assert(is_program(e)); ordinal = symbol_index(&e); label = e.elem.label; } - } *labels; - + }; + std::vector<program_label_t> labels; + cbl_prog_hier_t(); }; @@ -2027,13 +2107,11 @@ struct cbl_prog_hier_t { struct cbl_perform_tgt_t { struct cbl_until_addresses_t addresses; - cbl_perform_tgt_t() : ifrom(0), ito(0) {} - cbl_perform_tgt_t( cbl_label_t * from, cbl_label_t *to = NULL ) - : ifrom( from? symbol_index(symbol_elem_of(from)) : 0 ) + cbl_perform_tgt_t() : addresses(), ifrom(0), ito(0) {} + explicit cbl_perform_tgt_t( cbl_label_t * from, cbl_label_t *to = NULL ) + : addresses(), ifrom( from? symbol_index(symbol_elem_of(from)) : 0 ) , ito( to? symbol_index(symbol_elem_of(to)) : 0 ) - { - addresses = {}; - } + {} cbl_label_t * from( cbl_label_t * label ) { ifrom = symbol_index(symbol_elem_of(label)); @@ -2071,10 +2149,11 @@ struct cbl_perform_vary_t { struct cbl_refer_t by; // numeric struct cbl_field_t *until; // FldConditional - cbl_perform_vary_t( const cbl_refer_t& varying = cbl_refer_t(), - const cbl_refer_t& from = cbl_refer_t(), - const cbl_refer_t& by = cbl_refer_t(), - cbl_field_t *until = NULL ) + cbl_perform_vary_t() : until(nullptr) {} + cbl_perform_vary_t( const cbl_refer_t& varying, + const cbl_refer_t& from, + const cbl_refer_t& by, + cbl_field_t *until ) : varying(varying) , from(from) , by(by) @@ -2096,12 +2175,12 @@ is_literal( const cbl_field_t *field ) { } static inline bool -is_signable( const struct cbl_field_t *field ) { +is_signable( const cbl_field_t *field ) { return field->attr & signable_e; } static inline bool -is_temporary( const struct cbl_field_t *field ) { +is_temporary( const cbl_field_t *field ) { return field->attr & intermediate_e; } @@ -2122,7 +2201,7 @@ is_numeric( const cbl_field_t *field ) { bool cobol_filename( const char *name ); const char * cobol_filename(); -const char * cobol_fileline_set( const char line[] ); +int cobol_fileline_set( const char line[] ); char *cobol_name_mangler(const char *cobol_name); @@ -2236,7 +2315,7 @@ struct symbol_elem_t * symbol_special( size_t program, const char name[] ); struct symbol_elem_t * symbol_alphabet( size_t program, const char name[] ); struct symbol_elem_t * symbol_file( size_t program, const char name[] ); -struct cbl_field_t * symbol_file_record( struct cbl_file_t *file ); +struct cbl_field_t * symbol_file_record( const cbl_file_t *file ); cbl_file_t::varying_t symbol_file_record_sizes( struct cbl_file_t *file ); struct cbl_section_t * symbol_section( size_t program, struct cbl_section_t *section ); @@ -2246,7 +2325,7 @@ size_t symbol_label_id( const cbl_label_t *label ); struct cbl_field_t * parent_of( const cbl_field_t *f ); const cbl_field_t * occurs_in( const cbl_field_t *f ); -cbl_field_t *rename_not_ok( cbl_field_t *first, cbl_field_t *last); +cbl_field_t *rename_not_ok( const cbl_field_t *first, const cbl_field_t *last); bool immediately_follows( const cbl_field_t *first ); bool is_variable_length( const cbl_field_t *field ); @@ -2259,7 +2338,7 @@ uint64_t numeric_group_attrs( const cbl_field_t *field ); static inline struct cbl_field_t * field_at( size_t index ) { struct symbol_elem_t *e = symbol_at(index); - assert(e->type == SymField); + assert(e && e->type == SymField); return &e->elem.field; } @@ -2271,21 +2350,21 @@ size_t symbols_update( size_t first, bool parsed_ok = true ); void symbol_table_init(void); void symbol_table_check(void); -struct symbol_elem_t * symbol_typedef_add( size_t program, - struct cbl_field_t *field ); -struct symbol_elem_t * symbol_field_add( size_t program, - struct cbl_field_t *field ); -struct cbl_label_t * symbol_label_add( size_t program, - struct cbl_label_t *label ); -struct cbl_label_t * symbol_program_add( size_t program, cbl_label_t *input ); -struct symbol_elem_t * symbol_special_add( size_t program, - struct cbl_special_name_t *special ); -struct symbol_elem_t * symbol_alphabet_add( size_t program, - struct cbl_alphabet_t *alphabet ); -struct symbol_elem_t * symbol_file_add( size_t program, - struct cbl_file_t *file ); -struct symbol_elem_t * symbol_section_add( size_t program, - struct cbl_section_t *section ); +symbol_elem_t * symbol_typedef_add( size_t program, + cbl_field_t *field ); +symbol_elem_t * symbol_field_add( size_t program, + cbl_field_t *field ); +cbl_label_t * symbol_label_add( size_t program, + cbl_label_t *label ); +cbl_label_t * symbol_program_add( size_t program, cbl_label_t *input ); +symbol_elem_t * symbol_special_add( size_t program, + cbl_special_name_t *special ); +symbol_elem_t * symbol_alphabet_add( size_t program, + const cbl_alphabet_t *alphabet ); +symbol_elem_t * symbol_file_add( size_t program, + cbl_file_t *file ); +symbol_elem_t * symbol_section_add( size_t program, + cbl_section_t *section ); void symbol_field_location( size_t ifield, const YYLTYPE& loc ); YYLTYPE symbol_field_location( size_t ifield ); @@ -2312,17 +2391,178 @@ enum cbl_call_convention_t { cbl_call_cobol_e = 'N', // native }; +int keyword_tok( const char * text, bool include_intrinsics = false ); +int redefined_token( const cbl_name_t name ); + +class current_tokens_t { + class tokenset_t { + // token_names is initialized from a generated header file. + std::vector<const char *>token_names; // position indicates token value + std::map <std::string, int> tokens; // aliases + std::set<std::string> cobol_words; // Anything in COBOL-WORDS may appear only once. + public: + static std::string + lowercase( const cbl_name_t name ) { + cbl_name_t lname; + std::transform(name, name + strlen(name) + 1, lname, ftolower); + return lname; + } + static std::string + uppercase( const cbl_name_t name ) { + cbl_name_t uname; + std::transform(name, name + strlen(name) + 1, uname, ftoupper); + return uname; + } + + public: + tokenset_t(); + int find( const cbl_name_t name, bool include_intrinsics ); + + bool equate( const YYLTYPE& loc, int token, + const cbl_name_t name, const cbl_name_t verb = "EQUATE") { + auto lname( lowercase(name) ); + auto cw = cobol_words.insert(lname); + if( ! cw.second ) { + error_msg(loc, "COBOL-WORDS %s: %s may appear but once", verb, name); + return false; + } + auto p = tokens.find(lowercase(name)); + bool fOK = p == tokens.end(); + if( fOK ) { // name not already in use + tokens[lname] = token; + dbgmsg("%s:%d: %d has alias %s", __func__, __LINE__, token, name); + } else { + error_msg(loc, "%s: %s already defined as a token", verb, name); + } + return fOK; + } + bool undefine( const YYLTYPE& loc, + const cbl_name_t name, const cbl_name_t verb = "UNDEFINE" ) { + auto lname( lowercase(name) ); + auto cw = cobol_words.insert(lname); + if( ! cw.second ) { + error_msg(loc, "COBOL-WORDS %s: %s may appear but once", verb, name); + return false; + } + + // Do not erase generic, multi-type tokens COMPUTATIONAL and BINARY_INTEGER. + if( binary_integer_usage_of(name) ) { + dbgmsg("%s:%d: generic %s remains valid as a token", __func__, __LINE__, name); + return true; + } + + auto p = tokens.find(lname); + bool fOK = p != tokens.end(); + if( fOK ) { // name in use + tokens.erase(p); + } else { + error_msg(loc, "%s: %s not defined as a token", verb, name); + } + dbgmsg("%s:%d: %s removed as a valid token name", __func__, __LINE__, name); + return fOK; + } + + bool substitute( const YYLTYPE& loc, + const cbl_name_t extant, int token, const cbl_name_t name ) { + return + equate( loc, token, name, "SUBSTITUTE" ) + && + undefine( loc, extant, "SUBSTITUTE" ); + } + bool reserve( const YYLTYPE& loc, const cbl_name_t name ) { + auto lname( lowercase(name) ); + auto cw = cobol_words.insert(lname); + if( ! cw.second ) { + error_msg(loc, "COBOL-WORDS RESERVE: %s may appear but once", name); + return false; + } + tokens[lname] = -42; + return true; + } + int redefined_as( const cbl_name_t name ) { + auto lname( lowercase(name) ); + if( cobol_words.find(lname) != cobol_words.end() ) { + auto p = tokens.find(lname); + if( p != tokens.end() ) { + return p->second; + } + } + return 0; + } + const char * name_of( int tok ) const { + tok -= (255 + 3); + gcc_assert(0 <= tok && size_t(tok) < token_names.size()); + return tok < 0? "???" : token_names[tok]; + } + }; + + tokenset_t tokens; + public: + current_tokens_t() {} + int find( const cbl_name_t name, bool include_intrinsics ) { + return tokens.find(name, include_intrinsics); + } + bool equate( const YYLTYPE& loc, const cbl_name_t keyword, const cbl_name_t alias ) { + int token; + if( 0 == (token = binary_integer_usage_of(keyword)) ) { + if( 0 == (token = keyword_tok(keyword)) ) { + error_msg(loc, "EQUATE %s: not a valid token", keyword); + return false; + } + } + auto name = keyword_alias_add(tokens.uppercase(keyword), + tokens.uppercase(alias)); + if( name != keyword ) { + error_msg(loc, "EQUATE: %s is already an alias for %s", alias, name.c_str()); + return false; + } + return tokens.equate(loc, token, alias); + } + bool undefine( const YYLTYPE& loc, cbl_name_t keyword ) { + return tokens.undefine(loc, keyword); + } + bool substitute( const YYLTYPE& loc, const cbl_name_t keyword, const cbl_name_t alias ) { + int token; + if( 0 == (token = binary_integer_usage_of(keyword)) ) { + if( 0 == (token = keyword_tok(keyword)) ) { + error_msg(loc, "SUBSTITUTE %s: not a valid token", keyword); + return false; + } + } + auto name = keyword_alias_add(tokens.uppercase(keyword), + tokens.uppercase(alias)); + if( name != keyword ) { + error_msg(loc, "SUBSTITUTE: %s is already an alias for %s", alias, name.c_str()); + return false; + } + + dbgmsg("%s:%d: %s (%d) will have alias %s", __func__, __LINE__, keyword, token, alias); + return tokens.substitute(loc, keyword, token, alias); + } + bool reserve( const YYLTYPE& loc, const cbl_name_t name ) { + return tokens.reserve(loc, name); + } + int redefined_as( const cbl_name_t name ) { + return tokens.redefined_as(name); + } + const char * name_of( int tok ) const { + return tokens.name_of(tok); + } +}; + cbl_call_convention_t current_call_convention(); +current_tokens_t& cdf_current_tokens(); -cbl_call_convention_t +void current_call_convention( cbl_call_convention_t convention); class procref_base_t { private: const char *section_name, *paragraph_name; public: - procref_base_t( const char *section_name = NULL, - const char *paragraph_name = NULL ) + procref_base_t() : section_name(nullptr) , paragraph_name(nullptr) {} + procref_base_t( const char *section_name, + const char *paragraph_name ) : section_name(section_name) , paragraph_name(paragraph_name) {} @@ -2357,9 +2597,6 @@ public: int line_number() const { return line; } }; -int keyword_tok( const char * text, bool include_intrinsics = false ); -int redefined_token( const cbl_name_t name ); - void procedure_definition_add( size_t program, const cbl_label_t *procedure ); void procedure_reference_add( const char *sect, const char *para, int line, size_t context ); @@ -2375,12 +2612,8 @@ symbol_field_same_as( cbl_field_t *tgt, const cbl_field_t *src ); size_t symbol_file_same_record_area( std::list<cbl_file_t*>& files ); -cbl_field_t * -symbol_valid_udf_args( size_t function, - std::list<cbl_refer_t> args = std::list<cbl_refer_t>() ); - bool symbol_currency_add( const char symbol[], const char sign[] = NULL ); -const char * symbol_currency( char symbol ); +const char * symbol_currency( char symbol = '\0' ); const char * symbol_type_str( enum symbol_type_t type ); const char * cbl_field_type_str( enum cbl_field_type_t type ); @@ -2393,7 +2626,7 @@ refer_type_str( const cbl_refer_t *r ) { enum cbl_field_type_t symbol_field_type( size_t program, const char name[] ); -struct symbol_elem_t * symbol_parent( const struct symbol_elem_t *e ); +struct symbol_elem_t * symbol_parent( const symbol_elem_t *e ); int length_of_picture(const char *picture); int rdigits_of_picture(const char *picture); diff --git a/gcc/cobol/symfind.cc b/gcc/cobol/symfind.cc index ef8052c..8141b22 100644 --- a/gcc/cobol/symfind.cc +++ b/gcc/cobol/symfind.cc @@ -48,7 +48,7 @@ extern int yydebug; static bool is_data_field( symbol_elem_t& e ) { if( e.type != SymField ) return false; - auto f = cbl_field_of(&e); + const cbl_field_t *f = cbl_field_of(&e); if( f->name[0] == '\0' ) return false; if( is_filler(f) ) return false; @@ -129,7 +129,7 @@ finalize_symbol_map2() { for( auto& elem : symbol_map2 ) { auto& fields( elem.second ); fields.remove_if( []( auto isym ) { - auto f = cbl_field_of(symbol_at(isym)); + const cbl_field_t *f = cbl_field_of(symbol_at(isym)); return f->type == FldInvalid; } ); if( fields.empty() ) empties.insert(elem.first); @@ -275,8 +275,8 @@ update_symbol_map( symbol_elem_t *e ) { class is_name { const char *name; public: - is_name( const char *name ) : name(name) {} - bool operator()( symbol_map_t::value_type& elem ) { + explicit is_name( const char *name ) : name(name) {} + bool operator()( const symbol_map_t::value_type& elem ) { const bool tf = elem.first == name; return tf; } @@ -298,7 +298,7 @@ class reduce_ancestry { static symbol_map_t::mapped_type candidates_only( const symbol_map_t::value_type& elem ) { return elem.second; } public: - reduce_ancestry( const symbol_map_t& groups ) + explicit reduce_ancestry( const symbol_map_t& groups ) : candidates( groups.size() ) { std::transform( groups.begin(), groups.end(), candidates.begin(), @@ -316,9 +316,9 @@ public: if( p != item.second.end() ) { // Preserve symbol's index at front of ancestor list. symbol_map_t::mapped_type shorter(1 + ancestors->size()); - auto p = shorter.begin(); - *p = item.second.front(); - shorter.insert( ++p, ancestors->begin(), ancestors->end() ); + auto p_l = shorter.begin(); + *p_l = item.second.front(); + shorter.insert( ++p_l, ancestors->begin(), ancestors->end() ); return make_pair(item.first, shorter); } } @@ -331,7 +331,7 @@ public: class different_program { size_t program; public: - different_program( size_t program ) : program(program) {} + explicit different_program( size_t program ) : program(program) {} bool operator()( const symbol_map_t::value_type& item ) const { return ! item.first.same_program(program); } @@ -341,16 +341,16 @@ class in_scope { size_t program; static size_t prog_of( size_t program ) { - auto L = cbl_label_of(symbol_at(program)); + const cbl_label_t *L = cbl_label_of(symbol_at(program)); return L->parent; } public: - in_scope( size_t program ) : program(program) {} + explicit in_scope( size_t program ) : program(program) {} // A symbol is in scope if it's defined by this program or by an ancestor. bool operator()( const symbol_map_t::value_type& item ) const { - symbol_elem_t *e = symbol_at(item.second.front()); + const symbol_elem_t *e = symbol_at(item.second.front()); for( size_t prog = this->program; prog != 0; prog = prog_of(prog) ) { if( e->program == prog ) return true; } @@ -421,7 +421,7 @@ size_t end_of_group( size_t igroup ); static std::vector<size_t> symbol_match2( size_t program, - std::list<const char *> names, bool local = true ) + const std::list<const char *>& names, bool local = true ) { std::vector<size_t> fields; @@ -430,7 +430,7 @@ symbol_match2( size_t program, auto plist = symbol_map2.find(key); if( plist != symbol_map2.end() ) { for( auto candidate : plist->second ) { - auto e = symbol_at(candidate); + const symbol_elem_t *e = symbol_at(candidate); if( name_has_names( e, names, local ) ) { fields.push_back( symbol_index(e) ); } @@ -488,7 +488,7 @@ symbol_match2( size_t program, * N-1. */ static symbol_map_t -symbol_match( size_t program, std::list<const char *> names ) { +symbol_match( size_t program, const std::list<const char *>& names ) { auto matched = symbol_match2( program, names ); symbol_map_t output; @@ -504,7 +504,7 @@ symbol_match( size_t program, std::list<const char *> names ) { } auto inserted = output.insert(*p); if( ! inserted.second ) { - yyerror("%s is not a unique reference", key.name); + error_msg_direct("%s is not a unique reference", key.name); } } return output; @@ -561,7 +561,7 @@ symbol_find( size_t program, std::list<const char *> names ) { class in_group { size_t group; public: - in_group( size_t group ) : group(group) {} + explicit in_group( size_t group ) : group(group) {} bool operator()( symbol_map_t::const_reference elem ) const { return 0 < std::count( elem.second.begin(), diff --git a/gcc/cobol/token_names.h b/gcc/cobol/token_names.h index 682d68d..ca51510 100644 --- a/gcc/cobol/token_names.h +++ b/gcc/cobol/token_names.h @@ -1,5 +1,5 @@ // generated by ./token_names.h.gen ../../build/gcc/cobol/parse.h -// Thu May 8 18:53:33 EDT 2025 +// Tue Jul 8 19:21:28 EDT 2025 tokens = { { "identification", IDENTIFICATION_DIV }, // 258 { "environment", ENVIRONMENT_DIV }, // 259 @@ -137,560 +137,569 @@ tokens = { { "cdf-evaluate", CDF_EVALUATE }, // 388 { "cdf-when", CDF_WHEN }, // 389 { "cdf-end-evaluate", CDF_END_EVALUATE }, // 390 - { "call-cobol", CALL_COBOL }, // 391 - { "call-verbatim", CALL_VERBATIM }, // 392 - { "if", IF }, // 393 - { "then", THEN }, // 394 - { "else", ELSE }, // 395 - { "sentence", SENTENCE }, // 396 - { "accept", ACCEPT }, // 397 - { "add", ADD }, // 398 - { "alter", ALTER }, // 399 - { "call", CALL }, // 400 - { "cancel", CANCEL }, // 401 - { "close", CLOSE }, // 402 - { "compute", COMPUTE }, // 403 - { "continue", CONTINUE }, // 404 - { "delete", DELETE }, // 405 - { "display", DISPLAY }, // 406 - { "divide", DIVIDE }, // 407 - { "evaluate", EVALUATE }, // 408 - { "exit", EXIT }, // 409 - { "filler", FILLER_kw }, // 410 - { "goback", GOBACK }, // 411 - { "goto", GOTO }, // 412 - { "initialize", INITIALIZE }, // 413 - { "inspect", INSPECT }, // 414 - { "merge", MERGE }, // 415 - { "move", MOVE }, // 416 - { "multiply", MULTIPLY }, // 417 - { "open", OPEN }, // 418 - { "paragraph", PARAGRAPH }, // 419 - { "read", READ }, // 420 - { "release", RELEASE }, // 421 - { "return", RETURN }, // 422 - { "rewrite", REWRITE }, // 423 - { "search", SEARCH }, // 424 - { "set", SET }, // 425 - { "select", SELECT }, // 426 - { "sort", SORT }, // 427 - { "sort-merge", SORT_MERGE }, // 428 - { "string", STRING_kw }, // 429 - { "stop", STOP }, // 430 - { "subtract", SUBTRACT }, // 431 - { "start", START }, // 432 - { "unstring", UNSTRING }, // 433 - { "write", WRITE }, // 434 - { "when", WHEN }, // 435 - { "abs", ABS }, // 436 - { "access", ACCESS }, // 437 - { "acos", ACOS }, // 438 - { "actual", ACTUAL }, // 439 - { "advancing", ADVANCING }, // 440 - { "after", AFTER }, // 441 - { "all", ALL }, // 442 - { "allocate", ALLOCATE }, // 443 - { "alphabet", ALPHABET }, // 444 - { "alphabetic", ALPHABETIC }, // 445 - { "alphabetic-lower", ALPHABETIC_LOWER }, // 446 - { "alphabetic-upper", ALPHABETIC_UPPER }, // 447 - { "alphanumeric", ALPHANUMERIC }, // 448 - { "alphanumeric-edited", ALPHANUMERIC_EDITED }, // 449 - { "also", ALSO }, // 450 - { "alternate", ALTERNATE }, // 451 - { "annuity", ANNUITY }, // 452 - { "anum", ANUM }, // 453 - { "any", ANY }, // 454 - { "anycase", ANYCASE }, // 455 - { "apply", APPLY }, // 456 - { "are", ARE }, // 457 - { "area", AREA }, // 458 - { "areas", AREAS }, // 459 - { "as", AS }, // 460 - { "ascending", ASCENDING }, // 461 - { "activating", ACTIVATING }, // 462 - { "asin", ASIN }, // 463 - { "assign", ASSIGN }, // 464 - { "at", AT }, // 465 - { "atan", ATAN }, // 466 - { "based", BASED }, // 467 - { "baseconvert", BASECONVERT }, // 468 - { "before", BEFORE }, // 469 - { "binary", BINARY }, // 470 - { "bit", BIT }, // 471 - { "bit-of", BIT_OF }, // 472 - { "bit-to-char", BIT_TO_CHAR }, // 473 - { "blank", BLANK }, // 474 - { "block", BLOCK_kw }, // 475 - { "boolean-of-integer", BOOLEAN_OF_INTEGER }, // 476 - { "bottom", BOTTOM }, // 477 - { "by", BY }, // 478 - { "byte", BYTE }, // 479 - { "byte-length", BYTE_LENGTH }, // 480 - { "cf", CF }, // 481 - { "ch", CH }, // 482 - { "changed", CHANGED }, // 483 - { "char", CHAR }, // 484 - { "char-national", CHAR_NATIONAL }, // 485 - { "character", CHARACTER }, // 486 - { "characters", CHARACTERS }, // 487 - { "checking", CHECKING }, // 488 - { "class", CLASS }, // 489 - { "cobol", COBOL }, // 490 - { "code", CODE }, // 491 - { "code-set", CODESET }, // 492 - { "collating", COLLATING }, // 493 - { "column", COLUMN }, // 494 - { "combined-datetime", COMBINED_DATETIME }, // 495 - { "comma", COMMA }, // 496 - { "command-line", COMMAND_LINE }, // 497 - { "command-line-count", COMMAND_LINE_COUNT }, // 498 - { "commit", COMMIT }, // 499 - { "common", COMMON }, // 500 - { "concat", CONCAT }, // 501 - { "condition", CONDITION }, // 502 - { "configuration", CONFIGURATION_SECT }, // 503 - { "contains", CONTAINS }, // 504 - { "content", CONTENT }, // 505 - { "control", CONTROL }, // 506 - { "controls", CONTROLS }, // 507 - { "convert", CONVERT }, // 508 - { "converting", CONVERTING }, // 509 - { "corresponding", CORRESPONDING }, // 510 - { "cos", COS }, // 511 - { "count", COUNT }, // 512 - { "currency", CURRENCY }, // 513 - { "current", CURRENT }, // 514 - { "current-date", CURRENT_DATE }, // 515 - { "data", DATA }, // 516 - { "date", DATE }, // 517 - { "date-compiled", DATE_COMPILED }, // 518 - { "date-of-integer", DATE_OF_INTEGER }, // 519 - { "date-to-yyyymmdd", DATE_TO_YYYYMMDD }, // 520 - { "date-written", DATE_WRITTEN }, // 521 - { "day", DAY }, // 522 - { "day-of-integer", DAY_OF_INTEGER }, // 523 - { "day-of-week", DAY_OF_WEEK }, // 524 - { "day-to-yyyyddd", DAY_TO_YYYYDDD }, // 525 - { "dbcs", DBCS }, // 526 - { "de", DE }, // 527 - { "debugging", DEBUGGING }, // 528 - { "decimal-point", DECIMAL_POINT }, // 529 - { "declaratives", DECLARATIVES }, // 530 - { "default", DEFAULT }, // 531 - { "delimited", DELIMITED }, // 532 - { "delimiter", DELIMITER }, // 533 - { "depending", DEPENDING }, // 534 - { "descending", DESCENDING }, // 535 - { "detail", DETAIL }, // 536 - { "direct", DIRECT }, // 537 - { "direct-access", DIRECT_ACCESS }, // 538 - { "down", DOWN }, // 539 - { "duplicates", DUPLICATES }, // 540 - { "dynamic", DYNAMIC }, // 541 - { "e", E }, // 542 - { "ebcdic", EBCDIC }, // 543 - { "ec", EC }, // 544 - { "egcs", EGCS }, // 545 - { "entry", ENTRY }, // 546 - { "environment", ENVIRONMENT }, // 547 - { "equal", EQUAL }, // 548 - { "every", EVERY }, // 549 - { "examine", EXAMINE }, // 550 - { "exhibit", EXHIBIT }, // 551 - { "exp", EXP }, // 552 - { "exp10", EXP10 }, // 553 - { "extend", EXTEND }, // 554 - { "external", EXTERNAL }, // 555 - { "exception-file", EXCEPTION_FILE }, // 556 - { "exception-file-n", EXCEPTION_FILE_N }, // 557 - { "exception-location", EXCEPTION_LOCATION }, // 558 - { "exception-location-n", EXCEPTION_LOCATION_N }, // 559 - { "exception-statement", EXCEPTION_STATEMENT }, // 560 - { "exception-status", EXCEPTION_STATUS }, // 561 - { "factorial", FACTORIAL }, // 562 - { "false", FALSE_kw }, // 563 - { "fd", FD }, // 564 - { "file-control", FILE_CONTROL }, // 565 - { "file", FILE_KW }, // 566 - { "file-limit", FILE_LIMIT }, // 567 - { "final", FINAL }, // 568 - { "finally", FINALLY }, // 569 - { "find-string", FIND_STRING }, // 570 - { "first", FIRST }, // 571 - { "fixed", FIXED }, // 572 - { "footing", FOOTING }, // 573 - { "for", FOR }, // 574 - { "formatted-current-date", FORMATTED_CURRENT_DATE }, // 575 - { "formatted-date", FORMATTED_DATE }, // 576 - { "formatted-datetime", FORMATTED_DATETIME }, // 577 - { "formatted-time", FORMATTED_TIME }, // 578 - { "form-overflow", FORM_OVERFLOW }, // 579 - { "free", FREE }, // 580 - { "fraction-part", FRACTION_PART }, // 581 - { "from", FROM }, // 582 - { "function", FUNCTION }, // 583 - { "generate", GENERATE }, // 584 - { "giving", GIVING }, // 585 - { "global", GLOBAL }, // 586 - { "go", GO }, // 587 - { "group", GROUP }, // 588 - { "heading", HEADING }, // 589 - { "hex", HEX }, // 590 - { "hex-of", HEX_OF }, // 591 - { "hex-to-char", HEX_TO_CHAR }, // 592 - { "high-values", HIGH_VALUES }, // 593 - { "highest-algebraic", HIGHEST_ALGEBRAIC }, // 594 - { "hold", HOLD }, // 595 - { "ibm-360", IBM_360 }, // 596 - { "in", IN }, // 597 - { "include", INCLUDE }, // 598 - { "index", INDEX }, // 599 - { "indexed", INDEXED }, // 600 - { "indicate", INDICATE }, // 601 - { "initial", INITIAL_kw }, // 602 - { "initiate", INITIATE }, // 603 - { "input", INPUT }, // 604 - { "installation", INSTALLATION }, // 605 - { "interface", INTERFACE }, // 606 - { "integer", INTEGER }, // 607 - { "integer-of-boolean", INTEGER_OF_BOOLEAN }, // 608 - { "integer-of-date", INTEGER_OF_DATE }, // 609 - { "integer-of-day", INTEGER_OF_DAY }, // 610 - { "integer-of-formatted-date", INTEGER_OF_FORMATTED_DATE }, // 611 - { "integer-part", INTEGER_PART }, // 612 - { "into", INTO }, // 613 - { "intrinsic", INTRINSIC }, // 614 - { "invoke", INVOKE }, // 615 - { "i-o", IO }, // 616 - { "i-o-control", IO_CONTROL }, // 617 - { "is", IS }, // 618 - { "isnt", ISNT }, // 619 - { "kanji", KANJI }, // 620 - { "key", KEY }, // 621 - { "label", LABEL }, // 622 - { "last", LAST }, // 623 - { "leading", LEADING }, // 624 - { "left", LEFT }, // 625 - { "length", LENGTH }, // 626 - { "length-of", LENGTH_OF }, // 627 - { "limit", LIMIT }, // 628 - { "limits", LIMITS }, // 629 - { "line", LINE }, // 630 - { "lines", LINES }, // 631 - { "line-counter", LINE_COUNTER }, // 632 - { "linage", LINAGE }, // 633 - { "linkage", LINKAGE }, // 634 - { "locale", LOCALE }, // 635 - { "locale-compare", LOCALE_COMPARE }, // 636 - { "locale-date", LOCALE_DATE }, // 637 - { "locale-time", LOCALE_TIME }, // 638 - { "locale-time-from-seconds", LOCALE_TIME_FROM_SECONDS }, // 639 - { "local-storage", LOCAL_STORAGE }, // 640 - { "location", LOCATION }, // 641 - { "lock", LOCK }, // 642 - { "lock-on", LOCK_ON }, // 643 - { "log", LOG }, // 644 - { "log10", LOG10 }, // 645 - { "lower-case", LOWER_CASE }, // 646 - { "low-values", LOW_VALUES }, // 647 - { "lowest-algebraic", LOWEST_ALGEBRAIC }, // 648 - { "lparen", LPAREN }, // 649 - { "manual", MANUAL }, // 650 - { "maxx", MAXX }, // 651 - { "mean", MEAN }, // 652 - { "median", MEDIAN }, // 653 - { "midrange", MIDRANGE }, // 654 - { "minn", MINN }, // 655 - { "multiple", MULTIPLE }, // 656 - { "mod", MOD }, // 657 - { "mode", MODE }, // 658 - { "module-name", MODULE_NAME }, // 659 - { "named", NAMED }, // 660 - { "nat", NAT }, // 661 - { "national", NATIONAL }, // 662 - { "national-edited", NATIONAL_EDITED }, // 663 - { "national-of", NATIONAL_OF }, // 664 - { "native", NATIVE }, // 665 - { "nested", NESTED }, // 666 - { "next", NEXT }, // 667 - { "no", NO }, // 668 - { "note", NOTE }, // 669 - { "nulls", NULLS }, // 670 - { "null", NULLS }, // 670 - { "nullptr", NULLPTR }, // 671 - { "numeric", NUMERIC }, // 672 - { "numeric-edited", NUMERIC_EDITED }, // 673 - { "numval", NUMVAL }, // 674 - { "numval-c", NUMVAL_C }, // 675 - { "numval-f", NUMVAL_F }, // 676 - { "occurs", OCCURS }, // 677 - { "of", OF }, // 678 - { "off", OFF }, // 679 - { "omitted", OMITTED }, // 680 - { "on", ON }, // 681 - { "only", ONLY }, // 682 - { "optional", OPTIONAL }, // 683 - { "options", OPTIONS }, // 684 - { "ord", ORD }, // 685 - { "order", ORDER }, // 686 - { "ord-max", ORD_MAX }, // 687 - { "ord-min", ORD_MIN }, // 688 - { "organization", ORGANIZATION }, // 689 - { "other", OTHER }, // 690 - { "otherwise", OTHERWISE }, // 691 - { "output", OUTPUT }, // 692 - { "packed-decimal", PACKED_DECIMAL }, // 693 - { "padding", PADDING }, // 694 - { "page", PAGE }, // 695 - { "page-counter", PAGE_COUNTER }, // 696 - { "pf", PF }, // 697 - { "ph", PH }, // 698 - { "pi", PI }, // 699 - { "pic", PIC }, // 700 - { "picture", PICTURE }, // 701 - { "plus", PLUS }, // 702 - { "present-value", PRESENT_VALUE }, // 703 - { "print-switch", PRINT_SWITCH }, // 704 - { "procedure", PROCEDURE }, // 705 - { "procedures", PROCEDURES }, // 706 - { "proceed", PROCEED }, // 707 - { "process", PROCESS }, // 708 - { "program-id", PROGRAM_ID }, // 709 - { "program", PROGRAM_kw }, // 710 - { "property", PROPERTY }, // 711 - { "prototype", PROTOTYPE }, // 712 - { "pseudotext", PSEUDOTEXT }, // 713 - { "quotes", QUOTES }, // 714 - { "quote", QUOTES }, // 714 - { "random", RANDOM }, // 715 - { "random-seed", RANDOM_SEED }, // 716 - { "range", RANGE }, // 717 - { "raise", RAISE }, // 718 - { "raising", RAISING }, // 719 - { "rd", RD }, // 720 - { "record", RECORD }, // 721 - { "recording", RECORDING }, // 722 - { "records", RECORDS }, // 723 - { "recursive", RECURSIVE }, // 724 - { "redefines", REDEFINES }, // 725 - { "reel", REEL }, // 726 - { "reference", REFERENCE }, // 727 - { "relative", RELATIVE }, // 728 - { "rem", REM }, // 729 - { "remainder", REMAINDER }, // 730 - { "remarks", REMARKS }, // 731 - { "removal", REMOVAL }, // 732 - { "renames", RENAMES }, // 733 - { "replace", REPLACE }, // 734 - { "replacing", REPLACING }, // 735 - { "report", REPORT }, // 736 - { "reporting", REPORTING }, // 737 - { "reports", REPORTS }, // 738 - { "repository", REPOSITORY }, // 739 - { "rerun", RERUN }, // 740 - { "reserve", RESERVE }, // 741 - { "restricted", RESTRICTED }, // 742 - { "resume", RESUME }, // 743 - { "reverse", REVERSE }, // 744 - { "reversed", REVERSED }, // 745 - { "rewind", REWIND }, // 746 - { "rf", RF }, // 747 - { "rh", RH }, // 748 - { "right", RIGHT }, // 749 - { "rounded", ROUNDED }, // 750 - { "run", RUN }, // 751 - { "same", SAME }, // 752 - { "screen", SCREEN }, // 753 - { "sd", SD }, // 754 - { "seconds-from-formatted-time", SECONDS_FROM_FORMATTED_TIME }, // 755 - { "seconds-past-midnight", SECONDS_PAST_MIDNIGHT }, // 756 - { "security", SECURITY }, // 757 - { "separate", SEPARATE }, // 758 - { "sequence", SEQUENCE }, // 759 - { "sequential", SEQUENTIAL }, // 760 - { "sharing", SHARING }, // 761 - { "simple-exit", SIMPLE_EXIT }, // 762 - { "sign", SIGN }, // 763 - { "sin", SIN }, // 764 - { "size", SIZE }, // 765 - { "smallest-algebraic", SMALLEST_ALGEBRAIC }, // 766 - { "source", SOURCE }, // 767 - { "source-computer", SOURCE_COMPUTER }, // 768 - { "special-names", SPECIAL_NAMES }, // 769 - { "sqrt", SQRT }, // 770 - { "stack", STACK }, // 771 - { "standard", STANDARD }, // 772 - { "standard-1", STANDARD_1 }, // 773 - { "standard-deviation", STANDARD_DEVIATION }, // 774 - { "standard-compare", STANDARD_COMPARE }, // 775 - { "status", STATUS }, // 776 - { "strong", STRONG }, // 777 - { "substitute", SUBSTITUTE }, // 778 - { "sum", SUM }, // 779 - { "symbol", SYMBOL }, // 780 - { "symbolic", SYMBOLIC }, // 781 - { "synchronized", SYNCHRONIZED }, // 782 - { "tally", TALLY }, // 783 - { "tallying", TALLYING }, // 784 - { "tan", TAN }, // 785 - { "terminate", TERMINATE }, // 786 - { "test", TEST }, // 787 - { "test-date-yyyymmdd", TEST_DATE_YYYYMMDD }, // 788 - { "test-day-yyyyddd", TEST_DAY_YYYYDDD }, // 789 - { "test-formatted-datetime", TEST_FORMATTED_DATETIME }, // 790 - { "test-numval", TEST_NUMVAL }, // 791 - { "test-numval-c", TEST_NUMVAL_C }, // 792 - { "test-numval-f", TEST_NUMVAL_F }, // 793 - { "than", THAN }, // 794 - { "time", TIME }, // 795 - { "times", TIMES }, // 796 - { "to", TO }, // 797 - { "top", TOP }, // 798 - { "top-level", TOP_LEVEL }, // 799 - { "tracks", TRACKS }, // 800 - { "track-area", TRACK_AREA }, // 801 - { "trailing", TRAILING }, // 802 - { "transform", TRANSFORM }, // 803 - { "trim", TRIM }, // 804 - { "true", TRUE_kw }, // 805 - { "try", TRY }, // 806 - { "turn", TURN }, // 807 - { "type", TYPE }, // 808 - { "typedef", TYPEDEF }, // 809 - { "ulength", ULENGTH }, // 810 - { "unbounded", UNBOUNDED }, // 811 - { "unit", UNIT }, // 812 - { "units", UNITS }, // 813 - { "unit-record", UNIT_RECORD }, // 814 - { "until", UNTIL }, // 815 - { "up", UP }, // 816 - { "upon", UPON }, // 817 - { "upos", UPOS }, // 818 - { "upper-case", UPPER_CASE }, // 819 - { "usage", USAGE }, // 820 - { "using", USING }, // 821 - { "usubstr", USUBSTR }, // 822 - { "usupplementary", USUPPLEMENTARY }, // 823 - { "utility", UTILITY }, // 824 - { "uuid4", UUID4 }, // 825 - { "uvalid", UVALID }, // 826 - { "uwidth", UWIDTH }, // 827 - { "value", VALUE }, // 828 - { "variance", VARIANCE }, // 829 - { "varying", VARYING }, // 830 - { "volatile", VOLATILE }, // 831 - { "when-compiled", WHEN_COMPILED }, // 832 - { "with", WITH }, // 833 - { "working-storage", WORKING_STORAGE }, // 834 - { "xml", XML }, // 835 - { "xmlgenerate", XMLGENERATE }, // 836 - { "xmlparse", XMLPARSE }, // 837 - { "year-to-yyyy", YEAR_TO_YYYY }, // 838 - { "yyyyddd", YYYYDDD }, // 839 - { "yyyymmdd", YYYYMMDD }, // 840 - { "arithmetic", ARITHMETIC }, // 841 - { "attribute", ATTRIBUTE }, // 842 - { "auto", AUTO }, // 843 - { "automatic", AUTOMATIC }, // 844 - { "away-from-zero", AWAY_FROM_ZERO }, // 845 - { "background-color", BACKGROUND_COLOR }, // 846 - { "bell", BELL }, // 847 - { "binary-encoding", BINARY_ENCODING }, // 848 - { "blink", BLINK }, // 849 - { "capacity", CAPACITY }, // 850 - { "center", CENTER }, // 851 - { "classification", CLASSIFICATION }, // 852 - { "cycle", CYCLE }, // 853 - { "decimal-encoding", DECIMAL_ENCODING }, // 854 - { "entry-convention", ENTRY_CONVENTION }, // 855 - { "eol", EOL }, // 856 - { "eos", EOS }, // 857 - { "erase", ERASE }, // 858 - { "expands", EXPANDS }, // 859 - { "float-binary", FLOAT_BINARY }, // 860 - { "float-decimal", FLOAT_DECIMAL }, // 861 - { "foreground-color", FOREGROUND_COLOR }, // 862 - { "forever", FOREVER }, // 863 - { "full", FULL }, // 864 - { "highlight", HIGHLIGHT }, // 865 - { "high-order-left", HIGH_ORDER_LEFT }, // 866 - { "high-order-right", HIGH_ORDER_RIGHT }, // 867 - { "ignoring", IGNORING }, // 868 - { "implements", IMPLEMENTS }, // 869 - { "initialized", INITIALIZED }, // 870 - { "intermediate", INTERMEDIATE }, // 871 - { "lc-all", LC_ALL_kw }, // 872 - { "lc-collate", LC_COLLATE_kw }, // 873 - { "lc-ctype", LC_CTYPE_kw }, // 874 - { "lc-messages", LC_MESSAGES_kw }, // 875 - { "lc-monetary", LC_MONETARY_kw }, // 876 - { "lc-numeric", LC_NUMERIC_kw }, // 877 - { "lc-time", LC_TIME_kw }, // 878 - { "lowlight", LOWLIGHT }, // 879 - { "nearest-away-from-zero", NEAREST_AWAY_FROM_ZERO }, // 880 - { "nearest-even", NEAREST_EVEN }, // 881 - { "nearest-toward-zero", NEAREST_TOWARD_ZERO }, // 882 - { "none", NONE }, // 883 - { "normal", NORMAL }, // 884 - { "numbers", NUMBERS }, // 885 - { "prefixed", PREFIXED }, // 886 - { "previous", PREVIOUS }, // 887 - { "prohibited", PROHIBITED }, // 888 - { "relation", RELATION }, // 889 - { "required", REQUIRED }, // 890 - { "reverse-video", REVERSE_VIDEO }, // 891 - { "rounding", ROUNDING }, // 892 - { "seconds", SECONDS }, // 893 - { "secure", SECURE }, // 894 - { "short", SHORT }, // 895 - { "signed", SIGNED_kw }, // 896 - { "standard-binary", STANDARD_BINARY }, // 897 - { "standard-decimal", STANDARD_DECIMAL }, // 898 - { "statement", STATEMENT }, // 899 - { "step", STEP }, // 900 - { "structure", STRUCTURE }, // 901 - { "toward-greater", TOWARD_GREATER }, // 902 - { "toward-lesser", TOWARD_LESSER }, // 903 - { "truncation", TRUNCATION }, // 904 - { "ucs-4", UCS_4 }, // 905 - { "underline", UNDERLINE }, // 906 - { "unsigned", UNSIGNED_kw }, // 907 - { "utf-16", UTF_16 }, // 908 - { "utf-8", UTF_8 }, // 909 - { "address", ADDRESS }, // 910 - { "end-accept", END_ACCEPT }, // 911 - { "end-add", END_ADD }, // 912 - { "end-call", END_CALL }, // 913 - { "end-compute", END_COMPUTE }, // 914 - { "end-delete", END_DELETE }, // 915 - { "end-display", END_DISPLAY }, // 916 - { "end-divide", END_DIVIDE }, // 917 - { "end-evaluate", END_EVALUATE }, // 918 - { "end-multiply", END_MULTIPLY }, // 919 - { "end-perform", END_PERFORM }, // 920 - { "end-read", END_READ }, // 921 - { "end-return", END_RETURN }, // 922 - { "end-rewrite", END_REWRITE }, // 923 - { "end-search", END_SEARCH }, // 924 - { "end-start", END_START }, // 925 - { "end-string", END_STRING }, // 926 - { "end-subtract", END_SUBTRACT }, // 927 - { "end-unstring", END_UNSTRING }, // 928 - { "end-write", END_WRITE }, // 929 - { "end-if", END_IF }, // 930 - { "thru", THRU }, // 931 - { "through", THRU }, // 931 - { "or", OR }, // 932 - { "and", AND }, // 933 - { "not", NOT }, // 934 - { "ne", NE }, // 935 - { "le", LE }, // 936 - { "ge", GE }, // 937 - { "pow", POW }, // 938 - { "neg", NEG }, // 939 + { "call-convention", CALL_CONVENTION }, // 391 + { "call-cobol", CALL_COBOL }, // 392 + { "call-verbatim", CALL_VERBATIM }, // 393 + { "cdf-push", CDF_PUSH }, // 394 + { "cdf-pop", CDF_POP }, // 395 + { "source-format", SOURCE_FORMAT }, // 396 + { "if", IF }, // 397 + { "then", THEN }, // 398 + { "else", ELSE }, // 399 + { "sentence", SENTENCE }, // 400 + { "accept", ACCEPT }, // 401 + { "add", ADD }, // 402 + { "alter", ALTER }, // 403 + { "call", CALL }, // 404 + { "cancel", CANCEL }, // 405 + { "close", CLOSE }, // 406 + { "compute", COMPUTE }, // 407 + { "continue", CONTINUE }, // 408 + { "delete", DELETE }, // 409 + { "display", DISPLAY }, // 410 + { "divide", DIVIDE }, // 411 + { "evaluate", EVALUATE }, // 412 + { "exit", EXIT }, // 413 + { "filler", FILLER_kw }, // 414 + { "goback", GOBACK }, // 415 + { "goto", GOTO }, // 416 + { "initialize", INITIALIZE }, // 417 + { "inspect", INSPECT }, // 418 + { "merge", MERGE }, // 419 + { "move", MOVE }, // 420 + { "multiply", MULTIPLY }, // 421 + { "open", OPEN }, // 422 + { "paragraph", PARAGRAPH }, // 423 + { "read", READ }, // 424 + { "release", RELEASE }, // 425 + { "return", RETURN }, // 426 + { "rewrite", REWRITE }, // 427 + { "search", SEARCH }, // 428 + { "set", SET }, // 429 + { "select", SELECT }, // 430 + { "sort", SORT }, // 431 + { "sort-merge", SORT_MERGE }, // 432 + { "string", STRING_kw }, // 433 + { "stop", STOP }, // 434 + { "subtract", SUBTRACT }, // 435 + { "start", START }, // 436 + { "unstring", UNSTRING }, // 437 + { "write", WRITE }, // 438 + { "when", WHEN }, // 439 + { "argument-number", ARGUMENT_NUMBER }, // 440 + { "argument-value", ARGUMENT_VALUE }, // 441 + { "environment-name", ENVIRONMENT_NAME }, // 442 + { "environment-value", ENVIRONMENT_VALUE }, // 443 + { "abs", ABS }, // 444 + { "access", ACCESS }, // 445 + { "acos", ACOS }, // 446 + { "actual", ACTUAL }, // 447 + { "advancing", ADVANCING }, // 448 + { "after", AFTER }, // 449 + { "all", ALL }, // 450 + { "allocate", ALLOCATE }, // 451 + { "alphabet", ALPHABET }, // 452 + { "alphabetic", ALPHABETIC }, // 453 + { "alphabetic-lower", ALPHABETIC_LOWER }, // 454 + { "alphabetic-upper", ALPHABETIC_UPPER }, // 455 + { "alphanumeric", ALPHANUMERIC }, // 456 + { "alphanumeric-edited", ALPHANUMERIC_EDITED }, // 457 + { "also", ALSO }, // 458 + { "alternate", ALTERNATE }, // 459 + { "annuity", ANNUITY }, // 460 + { "anum", ANUM }, // 461 + { "any", ANY }, // 462 + { "anycase", ANYCASE }, // 463 + { "apply", APPLY }, // 464 + { "are", ARE }, // 465 + { "area", AREA }, // 466 + { "areas", AREAS }, // 467 + { "as", AS }, // 468 + { "ascending", ASCENDING }, // 469 + { "activating", ACTIVATING }, // 470 + { "asin", ASIN }, // 471 + { "assign", ASSIGN }, // 472 + { "at", AT }, // 473 + { "atan", ATAN }, // 474 + { "based", BASED }, // 475 + { "baseconvert", BASECONVERT }, // 476 + { "before", BEFORE }, // 477 + { "binary", BINARY }, // 478 + { "bit", BIT }, // 479 + { "bit-of", BIT_OF }, // 480 + { "bit-to-char", BIT_TO_CHAR }, // 481 + { "blank", BLANK }, // 482 + { "block", BLOCK_kw }, // 483 + { "boolean-of-integer", BOOLEAN_OF_INTEGER }, // 484 + { "bottom", BOTTOM }, // 485 + { "by", BY }, // 486 + { "byte", BYTE }, // 487 + { "byte-length", BYTE_LENGTH }, // 488 + { "cf", CF }, // 489 + { "ch", CH }, // 490 + { "changed", CHANGED }, // 491 + { "char", CHAR }, // 492 + { "char-national", CHAR_NATIONAL }, // 493 + { "character", CHARACTER }, // 494 + { "characters", CHARACTERS }, // 495 + { "checking", CHECKING }, // 496 + { "class", CLASS }, // 497 + { "cobol", COBOL }, // 498 + { "code", CODE }, // 499 + { "code-set", CODESET }, // 500 + { "collating", COLLATING }, // 501 + { "column", COLUMN }, // 502 + { "combined-datetime", COMBINED_DATETIME }, // 503 + { "comma", COMMA }, // 504 + { "command-line", COMMAND_LINE }, // 505 + { "command-line-count", COMMAND_LINE_COUNT }, // 506 + { "commit", COMMIT }, // 507 + { "common", COMMON }, // 508 + { "concat", CONCAT }, // 509 + { "condition", CONDITION }, // 510 + { "configuration", CONFIGURATION_SECT }, // 511 + { "contains", CONTAINS }, // 512 + { "content", CONTENT }, // 513 + { "control", CONTROL }, // 514 + { "controls", CONTROLS }, // 515 + { "convert", CONVERT }, // 516 + { "converting", CONVERTING }, // 517 + { "corresponding", CORRESPONDING }, // 518 + { "cos", COS }, // 519 + { "count", COUNT }, // 520 + { "currency", CURRENCY }, // 521 + { "current", CURRENT }, // 522 + { "current-date", CURRENT_DATE }, // 523 + { "data", DATA }, // 524 + { "date", DATE }, // 525 + { "date-compiled", DATE_COMPILED }, // 526 + { "date-of-integer", DATE_OF_INTEGER }, // 527 + { "date-to-yyyymmdd", DATE_TO_YYYYMMDD }, // 528 + { "date-written", DATE_WRITTEN }, // 529 + { "day", DAY }, // 530 + { "day-of-integer", DAY_OF_INTEGER }, // 531 + { "day-of-week", DAY_OF_WEEK }, // 532 + { "day-to-yyyyddd", DAY_TO_YYYYDDD }, // 533 + { "dbcs", DBCS }, // 534 + { "de", DE }, // 535 + { "debugging", DEBUGGING }, // 536 + { "decimal-point", DECIMAL_POINT }, // 537 + { "declaratives", DECLARATIVES }, // 538 + { "default", DEFAULT }, // 539 + { "delimited", DELIMITED }, // 540 + { "delimiter", DELIMITER }, // 541 + { "depending", DEPENDING }, // 542 + { "descending", DESCENDING }, // 543 + { "detail", DETAIL }, // 544 + { "direct", DIRECT }, // 545 + { "direct-access", DIRECT_ACCESS }, // 546 + { "down", DOWN }, // 547 + { "duplicates", DUPLICATES }, // 548 + { "dynamic", DYNAMIC }, // 549 + { "e", E }, // 550 + { "ebcdic", EBCDIC }, // 551 + { "ec", EC }, // 552 + { "egcs", EGCS }, // 553 + { "entry", ENTRY }, // 554 + { "environment", ENVIRONMENT }, // 555 + { "equal", EQUAL }, // 556 + { "every", EVERY }, // 557 + { "examine", EXAMINE }, // 558 + { "exhibit", EXHIBIT }, // 559 + { "exp", EXP }, // 560 + { "exp10", EXP10 }, // 561 + { "extend", EXTEND }, // 562 + { "external", EXTERNAL }, // 563 + { "exception-file", EXCEPTION_FILE }, // 564 + { "exception-file-n", EXCEPTION_FILE_N }, // 565 + { "exception-location", EXCEPTION_LOCATION }, // 566 + { "exception-location-n", EXCEPTION_LOCATION_N }, // 567 + { "exception-statement", EXCEPTION_STATEMENT }, // 568 + { "exception-status", EXCEPTION_STATUS }, // 569 + { "factorial", FACTORIAL }, // 570 + { "false", FALSE_kw }, // 571 + { "fd", FD }, // 572 + { "file-control", FILE_CONTROL }, // 573 + { "file", FILE_KW }, // 574 + { "file-limit", FILE_LIMIT }, // 575 + { "final", FINAL }, // 576 + { "finally", FINALLY }, // 577 + { "find-string", FIND_STRING }, // 578 + { "first", FIRST }, // 579 + { "fixed", FIXED }, // 580 + { "footing", FOOTING }, // 581 + { "for", FOR }, // 582 + { "formatted-current-date", FORMATTED_CURRENT_DATE }, // 583 + { "formatted-date", FORMATTED_DATE }, // 584 + { "formatted-datetime", FORMATTED_DATETIME }, // 585 + { "formatted-time", FORMATTED_TIME }, // 586 + { "form-overflow", FORM_OVERFLOW }, // 587 + { "free", FREE }, // 588 + { "fraction-part", FRACTION_PART }, // 589 + { "from", FROM }, // 590 + { "function", FUNCTION }, // 591 + { "generate", GENERATE }, // 592 + { "giving", GIVING }, // 593 + { "global", GLOBAL }, // 594 + { "go", GO }, // 595 + { "group", GROUP }, // 596 + { "heading", HEADING }, // 597 + { "hex", HEX }, // 598 + { "hex-of", HEX_OF }, // 599 + { "hex-to-char", HEX_TO_CHAR }, // 600 + { "high-values", HIGH_VALUES }, // 601 + { "highest-algebraic", HIGHEST_ALGEBRAIC }, // 602 + { "hold", HOLD }, // 603 + { "ibm-360", IBM_360 }, // 604 + { "in", IN }, // 605 + { "include", INCLUDE }, // 606 + { "index", INDEX }, // 607 + { "indexed", INDEXED }, // 608 + { "indicate", INDICATE }, // 609 + { "initial", INITIAL_kw }, // 610 + { "initiate", INITIATE }, // 611 + { "input", INPUT }, // 612 + { "installation", INSTALLATION }, // 613 + { "interface", INTERFACE }, // 614 + { "integer", INTEGER }, // 615 + { "integer-of-boolean", INTEGER_OF_BOOLEAN }, // 616 + { "integer-of-date", INTEGER_OF_DATE }, // 617 + { "integer-of-day", INTEGER_OF_DAY }, // 618 + { "integer-of-formatted-date", INTEGER_OF_FORMATTED_DATE }, // 619 + { "integer-part", INTEGER_PART }, // 620 + { "into", INTO }, // 621 + { "intrinsic", INTRINSIC }, // 622 + { "invoke", INVOKE }, // 623 + { "i-o", IO }, // 624 + { "i-o-control", IO_CONTROL }, // 625 + { "is", IS }, // 626 + { "isnt", ISNT }, // 627 + { "kanji", KANJI }, // 628 + { "key", KEY }, // 629 + { "label", LABEL }, // 630 + { "last", LAST }, // 631 + { "leading", LEADING }, // 632 + { "left", LEFT }, // 633 + { "length", LENGTH }, // 634 + { "length-of", LENGTH_OF }, // 635 + { "limit", LIMIT }, // 636 + { "limits", LIMITS }, // 637 + { "line", LINE }, // 638 + { "lines", LINES }, // 639 + { "line-counter", LINE_COUNTER }, // 640 + { "linage", LINAGE }, // 641 + { "linkage", LINKAGE }, // 642 + { "locale", LOCALE }, // 643 + { "locale-compare", LOCALE_COMPARE }, // 644 + { "locale-date", LOCALE_DATE }, // 645 + { "locale-time", LOCALE_TIME }, // 646 + { "locale-time-from-seconds", LOCALE_TIME_FROM_SECONDS }, // 647 + { "local-storage", LOCAL_STORAGE }, // 648 + { "location", LOCATION }, // 649 + { "lock", LOCK }, // 650 + { "lock-on", LOCK_ON }, // 651 + { "log", LOG }, // 652 + { "log10", LOG10 }, // 653 + { "lower-case", LOWER_CASE }, // 654 + { "low-values", LOW_VALUES }, // 655 + { "lowest-algebraic", LOWEST_ALGEBRAIC }, // 656 + { "lparen", LPAREN }, // 657 + { "manual", MANUAL }, // 658 + { "maxx", MAXX }, // 659 + { "mean", MEAN }, // 660 + { "median", MEDIAN }, // 661 + { "midrange", MIDRANGE }, // 662 + { "minn", MINN }, // 663 + { "multiple", MULTIPLE }, // 664 + { "mod", MOD }, // 665 + { "mode", MODE }, // 666 + { "module-name", MODULE_NAME }, // 667 + { "named", NAMED }, // 668 + { "nat", NAT }, // 669 + { "national", NATIONAL }, // 670 + { "national-edited", NATIONAL_EDITED }, // 671 + { "national-of", NATIONAL_OF }, // 672 + { "native", NATIVE }, // 673 + { "nested", NESTED }, // 674 + { "next", NEXT }, // 675 + { "no", NO }, // 676 + { "note", NOTE }, // 677 + { "nulls", NULLS }, // 678 + { "null", NULLS }, // 678 + { "nullptr", NULLPTR }, // 679 + { "numeric", NUMERIC }, // 680 + { "numeric-edited", NUMERIC_EDITED }, // 681 + { "numval", NUMVAL }, // 682 + { "numval-c", NUMVAL_C }, // 683 + { "numval-f", NUMVAL_F }, // 684 + { "occurs", OCCURS }, // 685 + { "of", OF }, // 686 + { "off", OFF }, // 687 + { "omitted", OMITTED }, // 688 + { "on", ON }, // 689 + { "only", ONLY }, // 690 + { "optional", OPTIONAL }, // 691 + { "options", OPTIONS }, // 692 + { "ord", ORD }, // 693 + { "order", ORDER }, // 694 + { "ord-max", ORD_MAX }, // 695 + { "ord-min", ORD_MIN }, // 696 + { "organization", ORGANIZATION }, // 697 + { "other", OTHER }, // 698 + { "otherwise", OTHERWISE }, // 699 + { "output", OUTPUT }, // 700 + { "packed-decimal", PACKED_DECIMAL }, // 701 + { "padding", PADDING }, // 702 + { "page", PAGE }, // 703 + { "page-counter", PAGE_COUNTER }, // 704 + { "pf", PF }, // 705 + { "ph", PH }, // 706 + { "pi", PI }, // 707 + { "pic", PIC }, // 708 + { "picture", PICTURE }, // 709 + { "plus", PLUS }, // 710 + { "present-value", PRESENT_VALUE }, // 711 + { "print-switch", PRINT_SWITCH }, // 712 + { "procedure", PROCEDURE }, // 713 + { "procedures", PROCEDURES }, // 714 + { "proceed", PROCEED }, // 715 + { "process", PROCESS }, // 716 + { "program-id", PROGRAM_ID }, // 717 + { "program", PROGRAM_kw }, // 718 + { "property", PROPERTY }, // 719 + { "prototype", PROTOTYPE }, // 720 + { "pseudotext", PSEUDOTEXT }, // 721 + { "quotes", QUOTES }, // 722 + { "quote", QUOTES }, // 722 + { "random", RANDOM }, // 723 + { "random-seed", RANDOM_SEED }, // 724 + { "range", RANGE }, // 725 + { "raise", RAISE }, // 726 + { "raising", RAISING }, // 727 + { "rd", RD }, // 728 + { "record", RECORD }, // 729 + { "recording", RECORDING }, // 730 + { "records", RECORDS }, // 731 + { "recursive", RECURSIVE }, // 732 + { "redefines", REDEFINES }, // 733 + { "reel", REEL }, // 734 + { "reference", REFERENCE }, // 735 + { "relative", RELATIVE }, // 736 + { "rem", REM }, // 737 + { "remainder", REMAINDER }, // 738 + { "remarks", REMARKS }, // 739 + { "removal", REMOVAL }, // 740 + { "renames", RENAMES }, // 741 + { "replace", REPLACE }, // 742 + { "replacing", REPLACING }, // 743 + { "report", REPORT }, // 744 + { "reporting", REPORTING }, // 745 + { "reports", REPORTS }, // 746 + { "repository", REPOSITORY }, // 747 + { "rerun", RERUN }, // 748 + { "reserve", RESERVE }, // 749 + { "restricted", RESTRICTED }, // 750 + { "resume", RESUME }, // 751 + { "reverse", REVERSE }, // 752 + { "reversed", REVERSED }, // 753 + { "rewind", REWIND }, // 754 + { "rf", RF }, // 755 + { "rh", RH }, // 756 + { "right", RIGHT }, // 757 + { "rounded", ROUNDED }, // 758 + { "run", RUN }, // 759 + { "same", SAME }, // 760 + { "screen", SCREEN }, // 761 + { "sd", SD }, // 762 + { "seconds-from-formatted-time", SECONDS_FROM_FORMATTED_TIME }, // 763 + { "seconds-past-midnight", SECONDS_PAST_MIDNIGHT }, // 764 + { "security", SECURITY }, // 765 + { "separate", SEPARATE }, // 766 + { "sequence", SEQUENCE }, // 767 + { "sequential", SEQUENTIAL }, // 768 + { "sharing", SHARING }, // 769 + { "simple-exit", SIMPLE_EXIT }, // 770 + { "sign", SIGN }, // 771 + { "sin", SIN }, // 772 + { "size", SIZE }, // 773 + { "smallest-algebraic", SMALLEST_ALGEBRAIC }, // 774 + { "source", SOURCE }, // 775 + { "source-computer", SOURCE_COMPUTER }, // 776 + { "special-names", SPECIAL_NAMES }, // 777 + { "sqrt", SQRT }, // 778 + { "stack", STACK }, // 779 + { "standard", STANDARD }, // 780 + { "standard-1", STANDARD_1 }, // 781 + { "standard-deviation", STANDARD_DEVIATION }, // 782 + { "standard-compare", STANDARD_COMPARE }, // 783 + { "status", STATUS }, // 784 + { "strong", STRONG }, // 785 + { "substitute", SUBSTITUTE }, // 786 + { "sum", SUM }, // 787 + { "symbol", SYMBOL }, // 788 + { "symbolic", SYMBOLIC }, // 789 + { "synchronized", SYNCHRONIZED }, // 790 + { "tally", TALLY }, // 791 + { "tallying", TALLYING }, // 792 + { "tan", TAN }, // 793 + { "terminate", TERMINATE }, // 794 + { "test", TEST }, // 795 + { "test-date-yyyymmdd", TEST_DATE_YYYYMMDD }, // 796 + { "test-day-yyyyddd", TEST_DAY_YYYYDDD }, // 797 + { "test-formatted-datetime", TEST_FORMATTED_DATETIME }, // 798 + { "test-numval", TEST_NUMVAL }, // 799 + { "test-numval-c", TEST_NUMVAL_C }, // 800 + { "test-numval-f", TEST_NUMVAL_F }, // 801 + { "than", THAN }, // 802 + { "time", TIME }, // 803 + { "times", TIMES }, // 804 + { "to", TO }, // 805 + { "top", TOP }, // 806 + { "top-level", TOP_LEVEL }, // 807 + { "tracks", TRACKS }, // 808 + { "track-area", TRACK_AREA }, // 809 + { "trailing", TRAILING }, // 810 + { "transform", TRANSFORM }, // 811 + { "trim", TRIM }, // 812 + { "true", TRUE_kw }, // 813 + { "try", TRY }, // 814 + { "turn", TURN }, // 815 + { "type", TYPE }, // 816 + { "typedef", TYPEDEF }, // 817 + { "ulength", ULENGTH }, // 818 + { "unbounded", UNBOUNDED }, // 819 + { "unit", UNIT }, // 820 + { "units", UNITS }, // 821 + { "unit-record", UNIT_RECORD }, // 822 + { "until", UNTIL }, // 823 + { "up", UP }, // 824 + { "upon", UPON }, // 825 + { "upos", UPOS }, // 826 + { "upper-case", UPPER_CASE }, // 827 + { "usage", USAGE }, // 828 + { "using", USING }, // 829 + { "usubstr", USUBSTR }, // 830 + { "usupplementary", USUPPLEMENTARY }, // 831 + { "utility", UTILITY }, // 832 + { "uuid4", UUID4 }, // 833 + { "uvalid", UVALID }, // 834 + { "uwidth", UWIDTH }, // 835 + { "value", VALUE }, // 836 + { "variance", VARIANCE }, // 837 + { "varying", VARYING }, // 838 + { "volatile", VOLATILE }, // 839 + { "when-compiled", WHEN_COMPILED }, // 840 + { "with", WITH }, // 841 + { "working-storage", WORKING_STORAGE }, // 842 + { "xml", XML }, // 843 + { "xmlgenerate", XMLGENERATE }, // 844 + { "xmlparse", XMLPARSE }, // 845 + { "year-to-yyyy", YEAR_TO_YYYY }, // 846 + { "yyyyddd", YYYYDDD }, // 847 + { "yyyymmdd", YYYYMMDD }, // 848 + { "arithmetic", ARITHMETIC }, // 849 + { "attribute", ATTRIBUTE }, // 850 + { "auto", AUTO }, // 851 + { "automatic", AUTOMATIC }, // 852 + { "away-from-zero", AWAY_FROM_ZERO }, // 853 + { "background-color", BACKGROUND_COLOR }, // 854 + { "bell", BELL }, // 855 + { "binary-encoding", BINARY_ENCODING }, // 856 + { "blink", BLINK }, // 857 + { "capacity", CAPACITY }, // 858 + { "center", CENTER }, // 859 + { "classification", CLASSIFICATION }, // 860 + { "cycle", CYCLE }, // 861 + { "decimal-encoding", DECIMAL_ENCODING }, // 862 + { "entry-convention", ENTRY_CONVENTION }, // 863 + { "eol", EOL }, // 864 + { "eos", EOS }, // 865 + { "erase", ERASE }, // 866 + { "expands", EXPANDS }, // 867 + { "float-binary", FLOAT_BINARY }, // 868 + { "float-decimal", FLOAT_DECIMAL }, // 869 + { "foreground-color", FOREGROUND_COLOR }, // 870 + { "forever", FOREVER }, // 871 + { "full", FULL }, // 872 + { "highlight", HIGHLIGHT }, // 873 + { "high-order-left", HIGH_ORDER_LEFT }, // 874 + { "high-order-right", HIGH_ORDER_RIGHT }, // 875 + { "ignoring", IGNORING }, // 876 + { "implements", IMPLEMENTS }, // 877 + { "initialized", INITIALIZED }, // 878 + { "intermediate", INTERMEDIATE }, // 879 + { "lc-all", LC_ALL_kw }, // 880 + { "lc-collate", LC_COLLATE_kw }, // 881 + { "lc-ctype", LC_CTYPE_kw }, // 882 + { "lc-messages", LC_MESSAGES_kw }, // 883 + { "lc-monetary", LC_MONETARY_kw }, // 884 + { "lc-numeric", LC_NUMERIC_kw }, // 885 + { "lc-time", LC_TIME_kw }, // 886 + { "lowlight", LOWLIGHT }, // 887 + { "nearest-away-from-zero", NEAREST_AWAY_FROM_ZERO }, // 888 + { "nearest-even", NEAREST_EVEN }, // 889 + { "nearest-toward-zero", NEAREST_TOWARD_ZERO }, // 890 + { "none", NONE }, // 891 + { "normal", NORMAL }, // 892 + { "numbers", NUMBERS }, // 893 + { "prefixed", PREFIXED }, // 894 + { "previous", PREVIOUS }, // 895 + { "prohibited", PROHIBITED }, // 896 + { "relation", RELATION }, // 897 + { "required", REQUIRED }, // 898 + { "reverse-video", REVERSE_VIDEO }, // 899 + { "rounding", ROUNDING }, // 900 + { "seconds", SECONDS }, // 901 + { "secure", SECURE }, // 902 + { "short", SHORT }, // 903 + { "signed", SIGNED_kw }, // 904 + { "standard-binary", STANDARD_BINARY }, // 905 + { "standard-decimal", STANDARD_DECIMAL }, // 906 + { "statement", STATEMENT }, // 907 + { "step", STEP }, // 908 + { "structure", STRUCTURE }, // 909 + { "toward-greater", TOWARD_GREATER }, // 910 + { "toward-lesser", TOWARD_LESSER }, // 911 + { "truncation", TRUNCATION }, // 912 + { "ucs-4", UCS_4 }, // 913 + { "underline", UNDERLINE }, // 914 + { "unsigned", UNSIGNED_kw }, // 915 + { "utf-16", UTF_16 }, // 916 + { "utf-8", UTF_8 }, // 917 + { "address", ADDRESS }, // 918 + { "end-accept", END_ACCEPT }, // 919 + { "end-add", END_ADD }, // 920 + { "end-call", END_CALL }, // 921 + { "end-compute", END_COMPUTE }, // 922 + { "end-delete", END_DELETE }, // 923 + { "end-display", END_DISPLAY }, // 924 + { "end-divide", END_DIVIDE }, // 925 + { "end-evaluate", END_EVALUATE }, // 926 + { "end-multiply", END_MULTIPLY }, // 927 + { "end-perform", END_PERFORM }, // 928 + { "end-read", END_READ }, // 929 + { "end-return", END_RETURN }, // 930 + { "end-rewrite", END_REWRITE }, // 931 + { "end-search", END_SEARCH }, // 932 + { "end-start", END_START }, // 933 + { "end-string", END_STRING }, // 934 + { "end-subtract", END_SUBTRACT }, // 935 + { "end-unstring", END_UNSTRING }, // 936 + { "end-write", END_WRITE }, // 937 + { "end-if", END_IF }, // 938 + { "thru", THRU }, // 939 + { "through", THRU }, // 939 + { "or", OR }, // 940 + { "and", AND }, // 941 + { "not", NOT }, // 942 + { "ne", NE }, // 943 + { "le", LE }, // 944 + { "ge", GE }, // 945 + { "pow", POW }, // 946 + { "neg", NEG }, // 947 }; +// cppcheck-suppress useInitializationList token_names = { "IDENTIFICATION", // 0 (258) "ENVIRONMENT", // 1 (259) @@ -825,553 +834,561 @@ token_names = { "CDF-EVALUATE", // 130 (388) "CDF-WHEN", // 131 (389) "CDF-END-EVALUATE", // 132 (390) - "CALL-COBOL", // 133 (391) - "CALL-VERBATIM", // 134 (392) - "IF", // 135 (393) - "THEN", // 136 (394) - "ELSE", // 137 (395) - "SENTENCE", // 138 (396) - "ACCEPT", // 139 (397) - "ADD", // 140 (398) - "ALTER", // 141 (399) - "CALL", // 142 (400) - "CANCEL", // 143 (401) - "CLOSE", // 144 (402) - "COMPUTE", // 145 (403) - "CONTINUE", // 146 (404) - "DELETE", // 147 (405) - "DISPLAY", // 148 (406) - "DIVIDE", // 149 (407) - "EVALUATE", // 150 (408) - "EXIT", // 151 (409) - "FILLER", // 152 (410) - "GOBACK", // 153 (411) - "GOTO", // 154 (412) - "INITIALIZE", // 155 (413) - "INSPECT", // 156 (414) - "MERGE", // 157 (415) - "MOVE", // 158 (416) - "MULTIPLY", // 159 (417) - "OPEN", // 160 (418) - "PARAGRAPH", // 161 (419) - "READ", // 162 (420) - "RELEASE", // 163 (421) - "RETURN", // 164 (422) - "REWRITE", // 165 (423) - "SEARCH", // 166 (424) - "SET", // 167 (425) - "SELECT", // 168 (426) - "SORT", // 169 (427) - "SORT-MERGE", // 170 (428) - "STRING", // 171 (429) - "STOP", // 172 (430) - "SUBTRACT", // 173 (431) - "START", // 174 (432) - "UNSTRING", // 175 (433) - "WRITE", // 176 (434) - "WHEN", // 177 (435) - "ABS", // 178 (436) - "ACCESS", // 179 (437) - "ACOS", // 180 (438) - "ACTUAL", // 181 (439) - "ADVANCING", // 182 (440) - "AFTER", // 183 (441) - "ALL", // 184 (442) - "ALLOCATE", // 185 (443) - "ALPHABET", // 186 (444) - "ALPHABETIC", // 187 (445) - "ALPHABETIC-LOWER", // 188 (446) - "ALPHABETIC-UPPER", // 189 (447) - "ALPHANUMERIC", // 190 (448) - "ALPHANUMERIC-EDITED", // 191 (449) - "ALSO", // 192 (450) - "ALTERNATE", // 193 (451) - "ANNUITY", // 194 (452) - "ANUM", // 195 (453) - "ANY", // 196 (454) - "ANYCASE", // 197 (455) - "APPLY", // 198 (456) - "ARE", // 199 (457) - "AREA", // 200 (458) - "AREAS", // 201 (459) - "AS", // 202 (460) - "ASCENDING", // 203 (461) - "ACTIVATING", // 204 (462) - "ASIN", // 205 (463) - "ASSIGN", // 206 (464) - "AT", // 207 (465) - "ATAN", // 208 (466) - "BASED", // 209 (467) - "BASECONVERT", // 210 (468) - "BEFORE", // 211 (469) - "BINARY", // 212 (470) - "BIT", // 213 (471) - "BIT-OF", // 214 (472) - "BIT-TO-CHAR", // 215 (473) - "BLANK", // 216 (474) - "BLOCK", // 217 (475) - "BOOLEAN-OF-INTEGER", // 218 (476) - "BOTTOM", // 219 (477) - "BY", // 220 (478) - "BYTE", // 221 (479) - "BYTE-LENGTH", // 222 (480) - "CF", // 223 (481) - "CH", // 224 (482) - "CHANGED", // 225 (483) - "CHAR", // 226 (484) - "CHAR-NATIONAL", // 227 (485) - "CHARACTER", // 228 (486) - "CHARACTERS", // 229 (487) - "CHECKING", // 230 (488) - "CLASS", // 231 (489) - "COBOL", // 232 (490) - "CODE", // 233 (491) - "CODE-SET", // 234 (492) - "COLLATING", // 235 (493) - "COLUMN", // 236 (494) - "COMBINED-DATETIME", // 237 (495) - "COMMA", // 238 (496) - "COMMAND-LINE", // 239 (497) - "COMMAND-LINE-COUNT", // 240 (498) - "COMMIT", // 241 (499) - "COMMON", // 242 (500) - "CONCAT", // 243 (501) - "CONDITION", // 244 (502) - "CONFIGURATION", // 245 (503) - "CONTAINS", // 246 (504) - "CONTENT", // 247 (505) - "CONTROL", // 248 (506) - "CONTROLS", // 249 (507) - "CONVERT", // 250 (508) - "CONVERTING", // 251 (509) - "CORRESPONDING", // 252 (510) - "COS", // 253 (511) - "COUNT", // 254 (512) - "CURRENCY", // 255 (513) - "CURRENT", // 256 (514) - "CURRENT-DATE", // 257 (515) - "DATA", // 258 (516) - "DATE", // 259 (517) - "DATE-COMPILED", // 260 (518) - "DATE-OF-INTEGER", // 261 (519) - "DATE-TO-YYYYMMDD", // 262 (520) - "DATE-WRITTEN", // 263 (521) - "DAY", // 264 (522) - "DAY-OF-INTEGER", // 265 (523) - "DAY-OF-WEEK", // 266 (524) - "DAY-TO-YYYYDDD", // 267 (525) - "DBCS", // 268 (526) - "DE", // 269 (527) - "DEBUGGING", // 270 (528) - "DECIMAL-POINT", // 271 (529) - "DECLARATIVES", // 272 (530) - "DEFAULT", // 273 (531) - "DELIMITED", // 274 (532) - "DELIMITER", // 275 (533) - "DEPENDING", // 276 (534) - "DESCENDING", // 277 (535) - "DETAIL", // 278 (536) - "DIRECT", // 279 (537) - "DIRECT-ACCESS", // 280 (538) - "DOWN", // 281 (539) - "DUPLICATES", // 282 (540) - "DYNAMIC", // 283 (541) - "E", // 284 (542) - "EBCDIC", // 285 (543) - "EC", // 286 (544) - "EGCS", // 287 (545) - "ENTRY", // 288 (546) - "ENVIRONMENT", // 289 (547) - "EQUAL", // 290 (548) - "EVERY", // 291 (549) - "EXAMINE", // 292 (550) - "EXHIBIT", // 293 (551) - "EXP", // 294 (552) - "EXP10", // 295 (553) - "EXTEND", // 296 (554) - "EXTERNAL", // 297 (555) - "EXCEPTION-FILE", // 298 (556) - "EXCEPTION-FILE-N", // 299 (557) - "EXCEPTION-LOCATION", // 300 (558) - "EXCEPTION-LOCATION-N", // 301 (559) - "EXCEPTION-STATEMENT", // 302 (560) - "EXCEPTION-STATUS", // 303 (561) - "FACTORIAL", // 304 (562) - "FALSE", // 305 (563) - "FD", // 306 (564) - "FILE-CONTROL", // 307 (565) - "FILE", // 308 (566) - "FILE-LIMIT", // 309 (567) - "FINAL", // 310 (568) - "FINALLY", // 311 (569) - "FIND-STRING", // 312 (570) - "FIRST", // 313 (571) - "FIXED", // 314 (572) - "FOOTING", // 315 (573) - "FOR", // 316 (574) - "FORMATTED-CURRENT-DATE", // 317 (575) - "FORMATTED-DATE", // 318 (576) - "FORMATTED-DATETIME", // 319 (577) - "FORMATTED-TIME", // 320 (578) - "FORM-OVERFLOW", // 321 (579) - "FREE", // 322 (580) - "FRACTION-PART", // 323 (581) - "FROM", // 324 (582) - "FUNCTION", // 325 (583) - "GENERATE", // 326 (584) - "GIVING", // 327 (585) - "GLOBAL", // 328 (586) - "GO", // 329 (587) - "GROUP", // 330 (588) - "HEADING", // 331 (589) - "HEX", // 332 (590) - "HEX-OF", // 333 (591) - "HEX-TO-CHAR", // 334 (592) - "HIGH-VALUES", // 335 (593) - "HIGHEST-ALGEBRAIC", // 336 (594) - "HOLD", // 337 (595) - "IBM-360", // 338 (596) - "IN", // 339 (597) - "INCLUDE", // 340 (598) - "INDEX", // 341 (599) - "INDEXED", // 342 (600) - "INDICATE", // 343 (601) - "INITIAL", // 344 (602) - "INITIATE", // 345 (603) - "INPUT", // 346 (604) - "INSTALLATION", // 347 (605) - "INTERFACE", // 348 (606) - "INTEGER", // 349 (607) - "INTEGER-OF-BOOLEAN", // 350 (608) - "INTEGER-OF-DATE", // 351 (609) - "INTEGER-OF-DAY", // 352 (610) - "INTEGER-OF-FORMATTED-DATE", // 353 (611) - "INTEGER-PART", // 354 (612) - "INTO", // 355 (613) - "INTRINSIC", // 356 (614) - "INVOKE", // 357 (615) - "I-O", // 358 (616) - "I-O-CONTROL", // 359 (617) - "IS", // 360 (618) - "ISNT", // 361 (619) - "KANJI", // 362 (620) - "KEY", // 363 (621) - "LABEL", // 364 (622) - "LAST", // 365 (623) - "LEADING", // 366 (624) - "LEFT", // 367 (625) - "LENGTH", // 368 (626) - "LENGTH-OF", // 369 (627) - "LIMIT", // 370 (628) - "LIMITS", // 371 (629) - "LINE", // 372 (630) - "LINES", // 373 (631) - "LINE-COUNTER", // 374 (632) - "LINAGE", // 375 (633) - "LINKAGE", // 376 (634) - "LOCALE", // 377 (635) - "LOCALE-COMPARE", // 378 (636) - "LOCALE-DATE", // 379 (637) - "LOCALE-TIME", // 380 (638) - "LOCALE-TIME-FROM-SECONDS", // 381 (639) - "LOCAL-STORAGE", // 382 (640) - "LOCATION", // 383 (641) - "LOCK", // 384 (642) - "LOCK-ON", // 385 (643) - "LOG", // 386 (644) - "LOG10", // 387 (645) - "LOWER-CASE", // 388 (646) - "LOW-VALUES", // 389 (647) - "LOWEST-ALGEBRAIC", // 390 (648) - "LPAREN", // 391 (649) - "MANUAL", // 392 (650) - "MAXX", // 393 (651) - "MEAN", // 394 (652) - "MEDIAN", // 395 (653) - "MIDRANGE", // 396 (654) - "MINN", // 397 (655) - "MULTIPLE", // 398 (656) - "MOD", // 399 (657) - "MODE", // 400 (658) - "MODULE-NAME", // 401 (659) - "NAMED", // 402 (660) - "NAT", // 403 (661) - "NATIONAL", // 404 (662) - "NATIONAL-EDITED", // 405 (663) - "NATIONAL-OF", // 406 (664) - "NATIVE", // 407 (665) - "NESTED", // 408 (666) - "NEXT", // 409 (667) - "NO", // 410 (668) - "NOTE", // 411 (669) - "NULLS", // 412 (670) - "NULLPTR", // 413 (671) - "NUMERIC", // 414 (672) - "NUMERIC-EDITED", // 415 (673) - "NUMVAL", // 416 (674) - "NUMVAL-C", // 417 (675) - "NUMVAL-F", // 418 (676) - "OCCURS", // 419 (677) - "OF", // 420 (678) - "OFF", // 421 (679) - "OMITTED", // 422 (680) - "ON", // 423 (681) - "ONLY", // 424 (682) - "OPTIONAL", // 425 (683) - "OPTIONS", // 426 (684) - "ORD", // 427 (685) - "ORDER", // 428 (686) - "ORD-MAX", // 429 (687) - "ORD-MIN", // 430 (688) - "ORGANIZATION", // 431 (689) - "OTHER", // 432 (690) - "OTHERWISE", // 433 (691) - "OUTPUT", // 434 (692) - "PACKED-DECIMAL", // 435 (693) - "PADDING", // 436 (694) - "PAGE", // 437 (695) - "PAGE-COUNTER", // 438 (696) - "PF", // 439 (697) - "PH", // 440 (698) - "PI", // 441 (699) - "PIC", // 442 (700) - "PICTURE", // 443 (701) - "PLUS", // 444 (702) - "PRESENT-VALUE", // 445 (703) - "PRINT-SWITCH", // 446 (704) - "PROCEDURE", // 447 (705) - "PROCEDURES", // 448 (706) - "PROCEED", // 449 (707) - "PROCESS", // 450 (708) - "PROGRAM-ID", // 451 (709) - "PROGRAM", // 452 (710) - "PROPERTY", // 453 (711) - "PROTOTYPE", // 454 (712) - "PSEUDOTEXT", // 455 (713) - "QUOTES", // 456 (714) - "RANDOM", // 457 (715) - "RANDOM-SEED", // 458 (716) - "RANGE", // 459 (717) - "RAISE", // 460 (718) - "RAISING", // 461 (719) - "RD", // 462 (720) - "RECORD", // 463 (721) - "RECORDING", // 464 (722) - "RECORDS", // 465 (723) - "RECURSIVE", // 466 (724) - "REDEFINES", // 467 (725) - "REEL", // 468 (726) - "REFERENCE", // 469 (727) - "RELATIVE", // 470 (728) - "REM", // 471 (729) - "REMAINDER", // 472 (730) - "REMARKS", // 473 (731) - "REMOVAL", // 474 (732) - "RENAMES", // 475 (733) - "REPLACE", // 476 (734) - "REPLACING", // 477 (735) - "REPORT", // 478 (736) - "REPORTING", // 479 (737) - "REPORTS", // 480 (738) - "REPOSITORY", // 481 (739) - "RERUN", // 482 (740) - "RESERVE", // 483 (741) - "RESTRICTED", // 484 (742) - "RESUME", // 485 (743) - "REVERSE", // 486 (744) - "REVERSED", // 487 (745) - "REWIND", // 488 (746) - "RF", // 489 (747) - "RH", // 490 (748) - "RIGHT", // 491 (749) - "ROUNDED", // 492 (750) - "RUN", // 493 (751) - "SAME", // 494 (752) - "SCREEN", // 495 (753) - "SD", // 496 (754) - "SECONDS-FROM-FORMATTED-TIME", // 497 (755) - "SECONDS-PAST-MIDNIGHT", // 498 (756) - "SECURITY", // 499 (757) - "SEPARATE", // 500 (758) - "SEQUENCE", // 501 (759) - "SEQUENTIAL", // 502 (760) - "SHARING", // 503 (761) - "SIMPLE-EXIT", // 504 (762) - "SIGN", // 505 (763) - "SIN", // 506 (764) - "SIZE", // 507 (765) - "SMALLEST-ALGEBRAIC", // 508 (766) - "SOURCE", // 509 (767) - "SOURCE-COMPUTER", // 510 (768) - "SPECIAL-NAMES", // 511 (769) - "SQRT", // 512 (770) - "STACK", // 513 (771) - "STANDARD", // 514 (772) - "STANDARD-1", // 515 (773) - "STANDARD-DEVIATION", // 516 (774) - "STANDARD-COMPARE", // 517 (775) - "STATUS", // 518 (776) - "STRONG", // 519 (777) - "SUBSTITUTE", // 520 (778) - "SUM", // 521 (779) - "SYMBOL", // 522 (780) - "SYMBOLIC", // 523 (781) - "SYNCHRONIZED", // 524 (782) - "TALLY", // 525 (783) - "TALLYING", // 526 (784) - "TAN", // 527 (785) - "TERMINATE", // 528 (786) - "TEST", // 529 (787) - "TEST-DATE-YYYYMMDD", // 530 (788) - "TEST-DAY-YYYYDDD", // 531 (789) - "TEST-FORMATTED-DATETIME", // 532 (790) - "TEST-NUMVAL", // 533 (791) - "TEST-NUMVAL-C", // 534 (792) - "TEST-NUMVAL-F", // 535 (793) - "THAN", // 536 (794) - "TIME", // 537 (795) - "TIMES", // 538 (796) - "TO", // 539 (797) - "TOP", // 540 (798) - "TOP-LEVEL", // 541 (799) - "TRACKS", // 542 (800) - "TRACK-AREA", // 543 (801) - "TRAILING", // 544 (802) - "TRANSFORM", // 545 (803) - "TRIM", // 546 (804) - "TRUE", // 547 (805) - "TRY", // 548 (806) - "TURN", // 549 (807) - "TYPE", // 550 (808) - "TYPEDEF", // 551 (809) - "ULENGTH", // 552 (810) - "UNBOUNDED", // 553 (811) - "UNIT", // 554 (812) - "UNITS", // 555 (813) - "UNIT-RECORD", // 556 (814) - "UNTIL", // 557 (815) - "UP", // 558 (816) - "UPON", // 559 (817) - "UPOS", // 560 (818) - "UPPER-CASE", // 561 (819) - "USAGE", // 562 (820) - "USING", // 563 (821) - "USUBSTR", // 564 (822) - "USUPPLEMENTARY", // 565 (823) - "UTILITY", // 566 (824) - "UUID4", // 567 (825) - "UVALID", // 568 (826) - "UWIDTH", // 569 (827) - "VALUE", // 570 (828) - "VARIANCE", // 571 (829) - "VARYING", // 572 (830) - "VOLATILE", // 573 (831) - "WHEN-COMPILED", // 574 (832) - "WITH", // 575 (833) - "WORKING-STORAGE", // 576 (834) - "XML", // 577 (835) - "XMLGENERATE", // 578 (836) - "XMLPARSE", // 579 (837) - "YEAR-TO-YYYY", // 580 (838) - "YYYYDDD", // 581 (839) - "YYYYMMDD", // 582 (840) - "ARITHMETIC", // 583 (841) - "ATTRIBUTE", // 584 (842) - "AUTO", // 585 (843) - "AUTOMATIC", // 586 (844) - "AWAY-FROM-ZERO", // 587 (845) - "BACKGROUND-COLOR", // 588 (846) - "BELL", // 589 (847) - "BINARY-ENCODING", // 590 (848) - "BLINK", // 591 (849) - "CAPACITY", // 592 (850) - "CENTER", // 593 (851) - "CLASSIFICATION", // 594 (852) - "CYCLE", // 595 (853) - "DECIMAL-ENCODING", // 596 (854) - "ENTRY-CONVENTION", // 597 (855) - "EOL", // 598 (856) - "EOS", // 599 (857) - "ERASE", // 600 (858) - "EXPANDS", // 601 (859) - "FLOAT-BINARY", // 602 (860) - "FLOAT-DECIMAL", // 603 (861) - "FOREGROUND-COLOR", // 604 (862) - "FOREVER", // 605 (863) - "FULL", // 606 (864) - "HIGHLIGHT", // 607 (865) - "HIGH-ORDER-LEFT", // 608 (866) - "HIGH-ORDER-RIGHT", // 609 (867) - "IGNORING", // 610 (868) - "IMPLEMENTS", // 611 (869) - "INITIALIZED", // 612 (870) - "INTERMEDIATE", // 613 (871) - "LC-ALL", // 614 (872) - "LC-COLLATE", // 615 (873) - "LC-CTYPE", // 616 (874) - "LC-MESSAGES", // 617 (875) - "LC-MONETARY", // 618 (876) - "LC-NUMERIC", // 619 (877) - "LC-TIME", // 620 (878) - "LOWLIGHT", // 621 (879) - "NEAREST-AWAY-FROM-ZERO", // 622 (880) - "NEAREST-EVEN", // 623 (881) - "NEAREST-TOWARD-ZERO", // 624 (882) - "NONE", // 625 (883) - "NORMAL", // 626 (884) - "NUMBERS", // 627 (885) - "PREFIXED", // 628 (886) - "PREVIOUS", // 629 (887) - "PROHIBITED", // 630 (888) - "RELATION", // 631 (889) - "REQUIRED", // 632 (890) - "REVERSE-VIDEO", // 633 (891) - "ROUNDING", // 634 (892) - "SECONDS", // 635 (893) - "SECURE", // 636 (894) - "SHORT", // 637 (895) - "SIGNED", // 638 (896) - "STANDARD-BINARY", // 639 (897) - "STANDARD-DECIMAL", // 640 (898) - "STATEMENT", // 641 (899) - "STEP", // 642 (900) - "STRUCTURE", // 643 (901) - "TOWARD-GREATER", // 644 (902) - "TOWARD-LESSER", // 645 (903) - "TRUNCATION", // 646 (904) - "UCS-4", // 647 (905) - "UNDERLINE", // 648 (906) - "UNSIGNED", // 649 (907) - "UTF-16", // 650 (908) - "UTF-8", // 651 (909) - "ADDRESS", // 652 (910) - "END-ACCEPT", // 653 (911) - "END-ADD", // 654 (912) - "END-CALL", // 655 (913) - "END-COMPUTE", // 656 (914) - "END-DELETE", // 657 (915) - "END-DISPLAY", // 658 (916) - "END-DIVIDE", // 659 (917) - "END-EVALUATE", // 660 (918) - "END-MULTIPLY", // 661 (919) - "END-PERFORM", // 662 (920) - "END-READ", // 663 (921) - "END-RETURN", // 664 (922) - "END-REWRITE", // 665 (923) - "END-SEARCH", // 666 (924) - "END-START", // 667 (925) - "END-STRING", // 668 (926) - "END-SUBTRACT", // 669 (927) - "END-UNSTRING", // 670 (928) - "END-WRITE", // 671 (929) - "END-IF", // 672 (930) - "THRU", // 673 (931) - "OR", // 674 (932) - "AND", // 675 (933) - "NOT", // 676 (934) - "NE", // 677 (935) - "LE", // 678 (936) - "GE", // 679 (937) - "POW", // 680 (938) - "NEG", // 681 (939) + "CALL-CONVENTION", // 133 (391) + "CALL-COBOL", // 134 (392) + "CALL-VERBATIM", // 135 (393) + "CDF-PUSH", // 136 (394) + "CDF-POP", // 137 (395) + "SOURCE-FORMAT", // 138 (396) + "IF", // 139 (397) + "THEN", // 140 (398) + "ELSE", // 141 (399) + "SENTENCE", // 142 (400) + "ACCEPT", // 143 (401) + "ADD", // 144 (402) + "ALTER", // 145 (403) + "CALL", // 146 (404) + "CANCEL", // 147 (405) + "CLOSE", // 148 (406) + "COMPUTE", // 149 (407) + "CONTINUE", // 150 (408) + "DELETE", // 151 (409) + "DISPLAY", // 152 (410) + "DIVIDE", // 153 (411) + "EVALUATE", // 154 (412) + "EXIT", // 155 (413) + "FILLER", // 156 (414) + "GOBACK", // 157 (415) + "GOTO", // 158 (416) + "INITIALIZE", // 159 (417) + "INSPECT", // 160 (418) + "MERGE", // 161 (419) + "MOVE", // 162 (420) + "MULTIPLY", // 163 (421) + "OPEN", // 164 (422) + "PARAGRAPH", // 165 (423) + "READ", // 166 (424) + "RELEASE", // 167 (425) + "RETURN", // 168 (426) + "REWRITE", // 169 (427) + "SEARCH", // 170 (428) + "SET", // 171 (429) + "SELECT", // 172 (430) + "SORT", // 173 (431) + "SORT-MERGE", // 174 (432) + "STRING", // 175 (433) + "STOP", // 176 (434) + "SUBTRACT", // 177 (435) + "START", // 178 (436) + "UNSTRING", // 179 (437) + "WRITE", // 180 (438) + "WHEN", // 181 (439) + "ARGUMENT-NUMBER", // 182 (440) + "ARGUMENT-VALUE", // 183 (441) + "ENVIRONMENT-NAME", // 184 (442) + "ENVIRONMENT-VALUE", // 185 (443) + "ABS", // 186 (444) + "ACCESS", // 187 (445) + "ACOS", // 188 (446) + "ACTUAL", // 189 (447) + "ADVANCING", // 190 (448) + "AFTER", // 191 (449) + "ALL", // 192 (450) + "ALLOCATE", // 193 (451) + "ALPHABET", // 194 (452) + "ALPHABETIC", // 195 (453) + "ALPHABETIC-LOWER", // 196 (454) + "ALPHABETIC-UPPER", // 197 (455) + "ALPHANUMERIC", // 198 (456) + "ALPHANUMERIC-EDITED", // 199 (457) + "ALSO", // 200 (458) + "ALTERNATE", // 201 (459) + "ANNUITY", // 202 (460) + "ANUM", // 203 (461) + "ANY", // 204 (462) + "ANYCASE", // 205 (463) + "APPLY", // 206 (464) + "ARE", // 207 (465) + "AREA", // 208 (466) + "AREAS", // 209 (467) + "AS", // 210 (468) + "ASCENDING", // 211 (469) + "ACTIVATING", // 212 (470) + "ASIN", // 213 (471) + "ASSIGN", // 214 (472) + "AT", // 215 (473) + "ATAN", // 216 (474) + "BASED", // 217 (475) + "BASECONVERT", // 218 (476) + "BEFORE", // 219 (477) + "BINARY", // 220 (478) + "BIT", // 221 (479) + "BIT-OF", // 222 (480) + "BIT-TO-CHAR", // 223 (481) + "BLANK", // 224 (482) + "BLOCK", // 225 (483) + "BOOLEAN-OF-INTEGER", // 226 (484) + "BOTTOM", // 227 (485) + "BY", // 228 (486) + "BYTE", // 229 (487) + "BYTE-LENGTH", // 230 (488) + "CF", // 231 (489) + "CH", // 232 (490) + "CHANGED", // 233 (491) + "CHAR", // 234 (492) + "CHAR-NATIONAL", // 235 (493) + "CHARACTER", // 236 (494) + "CHARACTERS", // 237 (495) + "CHECKING", // 238 (496) + "CLASS", // 239 (497) + "COBOL", // 240 (498) + "CODE", // 241 (499) + "CODE-SET", // 242 (500) + "COLLATING", // 243 (501) + "COLUMN", // 244 (502) + "COMBINED-DATETIME", // 245 (503) + "COMMA", // 246 (504) + "COMMAND-LINE", // 247 (505) + "COMMAND-LINE-COUNT", // 248 (506) + "COMMIT", // 249 (507) + "COMMON", // 250 (508) + "CONCAT", // 251 (509) + "CONDITION", // 252 (510) + "CONFIGURATION", // 253 (511) + "CONTAINS", // 254 (512) + "CONTENT", // 255 (513) + "CONTROL", // 256 (514) + "CONTROLS", // 257 (515) + "CONVERT", // 258 (516) + "CONVERTING", // 259 (517) + "CORRESPONDING", // 260 (518) + "COS", // 261 (519) + "COUNT", // 262 (520) + "CURRENCY", // 263 (521) + "CURRENT", // 264 (522) + "CURRENT-DATE", // 265 (523) + "DATA", // 266 (524) + "DATE", // 267 (525) + "DATE-COMPILED", // 268 (526) + "DATE-OF-INTEGER", // 269 (527) + "DATE-TO-YYYYMMDD", // 270 (528) + "DATE-WRITTEN", // 271 (529) + "DAY", // 272 (530) + "DAY-OF-INTEGER", // 273 (531) + "DAY-OF-WEEK", // 274 (532) + "DAY-TO-YYYYDDD", // 275 (533) + "DBCS", // 276 (534) + "DE", // 277 (535) + "DEBUGGING", // 278 (536) + "DECIMAL-POINT", // 279 (537) + "DECLARATIVES", // 280 (538) + "DEFAULT", // 281 (539) + "DELIMITED", // 282 (540) + "DELIMITER", // 283 (541) + "DEPENDING", // 284 (542) + "DESCENDING", // 285 (543) + "DETAIL", // 286 (544) + "DIRECT", // 287 (545) + "DIRECT-ACCESS", // 288 (546) + "DOWN", // 289 (547) + "DUPLICATES", // 290 (548) + "DYNAMIC", // 291 (549) + "E", // 292 (550) + "EBCDIC", // 293 (551) + "EC", // 294 (552) + "EGCS", // 295 (553) + "ENTRY", // 296 (554) + "ENVIRONMENT", // 297 (555) + "EQUAL", // 298 (556) + "EVERY", // 299 (557) + "EXAMINE", // 300 (558) + "EXHIBIT", // 301 (559) + "EXP", // 302 (560) + "EXP10", // 303 (561) + "EXTEND", // 304 (562) + "EXTERNAL", // 305 (563) + "EXCEPTION-FILE", // 306 (564) + "EXCEPTION-FILE-N", // 307 (565) + "EXCEPTION-LOCATION", // 308 (566) + "EXCEPTION-LOCATION-N", // 309 (567) + "EXCEPTION-STATEMENT", // 310 (568) + "EXCEPTION-STATUS", // 311 (569) + "FACTORIAL", // 312 (570) + "FALSE", // 313 (571) + "FD", // 314 (572) + "FILE-CONTROL", // 315 (573) + "FILE", // 316 (574) + "FILE-LIMIT", // 317 (575) + "FINAL", // 318 (576) + "FINALLY", // 319 (577) + "FIND-STRING", // 320 (578) + "FIRST", // 321 (579) + "FIXED", // 322 (580) + "FOOTING", // 323 (581) + "FOR", // 324 (582) + "FORMATTED-CURRENT-DATE", // 325 (583) + "FORMATTED-DATE", // 326 (584) + "FORMATTED-DATETIME", // 327 (585) + "FORMATTED-TIME", // 328 (586) + "FORM-OVERFLOW", // 329 (587) + "FREE", // 330 (588) + "FRACTION-PART", // 331 (589) + "FROM", // 332 (590) + "FUNCTION", // 333 (591) + "GENERATE", // 334 (592) + "GIVING", // 335 (593) + "GLOBAL", // 336 (594) + "GO", // 337 (595) + "GROUP", // 338 (596) + "HEADING", // 339 (597) + "HEX", // 340 (598) + "HEX-OF", // 341 (599) + "HEX-TO-CHAR", // 342 (600) + "HIGH-VALUES", // 343 (601) + "HIGHEST-ALGEBRAIC", // 344 (602) + "HOLD", // 345 (603) + "IBM-360", // 346 (604) + "IN", // 347 (605) + "INCLUDE", // 348 (606) + "INDEX", // 349 (607) + "INDEXED", // 350 (608) + "INDICATE", // 351 (609) + "INITIAL", // 352 (610) + "INITIATE", // 353 (611) + "INPUT", // 354 (612) + "INSTALLATION", // 355 (613) + "INTERFACE", // 356 (614) + "INTEGER", // 357 (615) + "INTEGER-OF-BOOLEAN", // 358 (616) + "INTEGER-OF-DATE", // 359 (617) + "INTEGER-OF-DAY", // 360 (618) + "INTEGER-OF-FORMATTED-DATE", // 361 (619) + "INTEGER-PART", // 362 (620) + "INTO", // 363 (621) + "INTRINSIC", // 364 (622) + "INVOKE", // 365 (623) + "I-O", // 366 (624) + "I-O-CONTROL", // 367 (625) + "IS", // 368 (626) + "ISNT", // 369 (627) + "KANJI", // 370 (628) + "KEY", // 371 (629) + "LABEL", // 372 (630) + "LAST", // 373 (631) + "LEADING", // 374 (632) + "LEFT", // 375 (633) + "LENGTH", // 376 (634) + "LENGTH-OF", // 377 (635) + "LIMIT", // 378 (636) + "LIMITS", // 379 (637) + "LINE", // 380 (638) + "LINES", // 381 (639) + "LINE-COUNTER", // 382 (640) + "LINAGE", // 383 (641) + "LINKAGE", // 384 (642) + "LOCALE", // 385 (643) + "LOCALE-COMPARE", // 386 (644) + "LOCALE-DATE", // 387 (645) + "LOCALE-TIME", // 388 (646) + "LOCALE-TIME-FROM-SECONDS", // 389 (647) + "LOCAL-STORAGE", // 390 (648) + "LOCATION", // 391 (649) + "LOCK", // 392 (650) + "LOCK-ON", // 393 (651) + "LOG", // 394 (652) + "LOG10", // 395 (653) + "LOWER-CASE", // 396 (654) + "LOW-VALUES", // 397 (655) + "LOWEST-ALGEBRAIC", // 398 (656) + "LPAREN", // 399 (657) + "MANUAL", // 400 (658) + "MAXX", // 401 (659) + "MEAN", // 402 (660) + "MEDIAN", // 403 (661) + "MIDRANGE", // 404 (662) + "MINN", // 405 (663) + "MULTIPLE", // 406 (664) + "MOD", // 407 (665) + "MODE", // 408 (666) + "MODULE-NAME", // 409 (667) + "NAMED", // 410 (668) + "NAT", // 411 (669) + "NATIONAL", // 412 (670) + "NATIONAL-EDITED", // 413 (671) + "NATIONAL-OF", // 414 (672) + "NATIVE", // 415 (673) + "NESTED", // 416 (674) + "NEXT", // 417 (675) + "NO", // 418 (676) + "NOTE", // 419 (677) + "NULLS", // 420 (678) + "NULLPTR", // 421 (679) + "NUMERIC", // 422 (680) + "NUMERIC-EDITED", // 423 (681) + "NUMVAL", // 424 (682) + "NUMVAL-C", // 425 (683) + "NUMVAL-F", // 426 (684) + "OCCURS", // 427 (685) + "OF", // 428 (686) + "OFF", // 429 (687) + "OMITTED", // 430 (688) + "ON", // 431 (689) + "ONLY", // 432 (690) + "OPTIONAL", // 433 (691) + "OPTIONS", // 434 (692) + "ORD", // 435 (693) + "ORDER", // 436 (694) + "ORD-MAX", // 437 (695) + "ORD-MIN", // 438 (696) + "ORGANIZATION", // 439 (697) + "OTHER", // 440 (698) + "OTHERWISE", // 441 (699) + "OUTPUT", // 442 (700) + "PACKED-DECIMAL", // 443 (701) + "PADDING", // 444 (702) + "PAGE", // 445 (703) + "PAGE-COUNTER", // 446 (704) + "PF", // 447 (705) + "PH", // 448 (706) + "PI", // 449 (707) + "PIC", // 450 (708) + "PICTURE", // 451 (709) + "PLUS", // 452 (710) + "PRESENT-VALUE", // 453 (711) + "PRINT-SWITCH", // 454 (712) + "PROCEDURE", // 455 (713) + "PROCEDURES", // 456 (714) + "PROCEED", // 457 (715) + "PROCESS", // 458 (716) + "PROGRAM-ID", // 459 (717) + "PROGRAM", // 460 (718) + "PROPERTY", // 461 (719) + "PROTOTYPE", // 462 (720) + "PSEUDOTEXT", // 463 (721) + "QUOTES", // 464 (722) + "RANDOM", // 465 (723) + "RANDOM-SEED", // 466 (724) + "RANGE", // 467 (725) + "RAISE", // 468 (726) + "RAISING", // 469 (727) + "RD", // 470 (728) + "RECORD", // 471 (729) + "RECORDING", // 472 (730) + "RECORDS", // 473 (731) + "RECURSIVE", // 474 (732) + "REDEFINES", // 475 (733) + "REEL", // 476 (734) + "REFERENCE", // 477 (735) + "RELATIVE", // 478 (736) + "REM", // 479 (737) + "REMAINDER", // 480 (738) + "REMARKS", // 481 (739) + "REMOVAL", // 482 (740) + "RENAMES", // 483 (741) + "REPLACE", // 484 (742) + "REPLACING", // 485 (743) + "REPORT", // 486 (744) + "REPORTING", // 487 (745) + "REPORTS", // 488 (746) + "REPOSITORY", // 489 (747) + "RERUN", // 490 (748) + "RESERVE", // 491 (749) + "RESTRICTED", // 492 (750) + "RESUME", // 493 (751) + "REVERSE", // 494 (752) + "REVERSED", // 495 (753) + "REWIND", // 496 (754) + "RF", // 497 (755) + "RH", // 498 (756) + "RIGHT", // 499 (757) + "ROUNDED", // 500 (758) + "RUN", // 501 (759) + "SAME", // 502 (760) + "SCREEN", // 503 (761) + "SD", // 504 (762) + "SECONDS-FROM-FORMATTED-TIME", // 505 (763) + "SECONDS-PAST-MIDNIGHT", // 506 (764) + "SECURITY", // 507 (765) + "SEPARATE", // 508 (766) + "SEQUENCE", // 509 (767) + "SEQUENTIAL", // 510 (768) + "SHARING", // 511 (769) + "SIMPLE-EXIT", // 512 (770) + "SIGN", // 513 (771) + "SIN", // 514 (772) + "SIZE", // 515 (773) + "SMALLEST-ALGEBRAIC", // 516 (774) + "SOURCE", // 517 (775) + "SOURCE-COMPUTER", // 518 (776) + "SPECIAL-NAMES", // 519 (777) + "SQRT", // 520 (778) + "STACK", // 521 (779) + "STANDARD", // 522 (780) + "STANDARD-1", // 523 (781) + "STANDARD-DEVIATION", // 524 (782) + "STANDARD-COMPARE", // 525 (783) + "STATUS", // 526 (784) + "STRONG", // 527 (785) + "SUBSTITUTE", // 528 (786) + "SUM", // 529 (787) + "SYMBOL", // 530 (788) + "SYMBOLIC", // 531 (789) + "SYNCHRONIZED", // 532 (790) + "TALLY", // 533 (791) + "TALLYING", // 534 (792) + "TAN", // 535 (793) + "TERMINATE", // 536 (794) + "TEST", // 537 (795) + "TEST-DATE-YYYYMMDD", // 538 (796) + "TEST-DAY-YYYYDDD", // 539 (797) + "TEST-FORMATTED-DATETIME", // 540 (798) + "TEST-NUMVAL", // 541 (799) + "TEST-NUMVAL-C", // 542 (800) + "TEST-NUMVAL-F", // 543 (801) + "THAN", // 544 (802) + "TIME", // 545 (803) + "TIMES", // 546 (804) + "TO", // 547 (805) + "TOP", // 548 (806) + "TOP-LEVEL", // 549 (807) + "TRACKS", // 550 (808) + "TRACK-AREA", // 551 (809) + "TRAILING", // 552 (810) + "TRANSFORM", // 553 (811) + "TRIM", // 554 (812) + "TRUE", // 555 (813) + "TRY", // 556 (814) + "TURN", // 557 (815) + "TYPE", // 558 (816) + "TYPEDEF", // 559 (817) + "ULENGTH", // 560 (818) + "UNBOUNDED", // 561 (819) + "UNIT", // 562 (820) + "UNITS", // 563 (821) + "UNIT-RECORD", // 564 (822) + "UNTIL", // 565 (823) + "UP", // 566 (824) + "UPON", // 567 (825) + "UPOS", // 568 (826) + "UPPER-CASE", // 569 (827) + "USAGE", // 570 (828) + "USING", // 571 (829) + "USUBSTR", // 572 (830) + "USUPPLEMENTARY", // 573 (831) + "UTILITY", // 574 (832) + "UUID4", // 575 (833) + "UVALID", // 576 (834) + "UWIDTH", // 577 (835) + "VALUE", // 578 (836) + "VARIANCE", // 579 (837) + "VARYING", // 580 (838) + "VOLATILE", // 581 (839) + "WHEN-COMPILED", // 582 (840) + "WITH", // 583 (841) + "WORKING-STORAGE", // 584 (842) + "XML", // 585 (843) + "XMLGENERATE", // 586 (844) + "XMLPARSE", // 587 (845) + "YEAR-TO-YYYY", // 588 (846) + "YYYYDDD", // 589 (847) + "YYYYMMDD", // 590 (848) + "ARITHMETIC", // 591 (849) + "ATTRIBUTE", // 592 (850) + "AUTO", // 593 (851) + "AUTOMATIC", // 594 (852) + "AWAY-FROM-ZERO", // 595 (853) + "BACKGROUND-COLOR", // 596 (854) + "BELL", // 597 (855) + "BINARY-ENCODING", // 598 (856) + "BLINK", // 599 (857) + "CAPACITY", // 600 (858) + "CENTER", // 601 (859) + "CLASSIFICATION", // 602 (860) + "CYCLE", // 603 (861) + "DECIMAL-ENCODING", // 604 (862) + "ENTRY-CONVENTION", // 605 (863) + "EOL", // 606 (864) + "EOS", // 607 (865) + "ERASE", // 608 (866) + "EXPANDS", // 609 (867) + "FLOAT-BINARY", // 610 (868) + "FLOAT-DECIMAL", // 611 (869) + "FOREGROUND-COLOR", // 612 (870) + "FOREVER", // 613 (871) + "FULL", // 614 (872) + "HIGHLIGHT", // 615 (873) + "HIGH-ORDER-LEFT", // 616 (874) + "HIGH-ORDER-RIGHT", // 617 (875) + "IGNORING", // 618 (876) + "IMPLEMENTS", // 619 (877) + "INITIALIZED", // 620 (878) + "INTERMEDIATE", // 621 (879) + "LC-ALL", // 622 (880) + "LC-COLLATE", // 623 (881) + "LC-CTYPE", // 624 (882) + "LC-MESSAGES", // 625 (883) + "LC-MONETARY", // 626 (884) + "LC-NUMERIC", // 627 (885) + "LC-TIME", // 628 (886) + "LOWLIGHT", // 629 (887) + "NEAREST-AWAY-FROM-ZERO", // 630 (888) + "NEAREST-EVEN", // 631 (889) + "NEAREST-TOWARD-ZERO", // 632 (890) + "NONE", // 633 (891) + "NORMAL", // 634 (892) + "NUMBERS", // 635 (893) + "PREFIXED", // 636 (894) + "PREVIOUS", // 637 (895) + "PROHIBITED", // 638 (896) + "RELATION", // 639 (897) + "REQUIRED", // 640 (898) + "REVERSE-VIDEO", // 641 (899) + "ROUNDING", // 642 (900) + "SECONDS", // 643 (901) + "SECURE", // 644 (902) + "SHORT", // 645 (903) + "SIGNED", // 646 (904) + "STANDARD-BINARY", // 647 (905) + "STANDARD-DECIMAL", // 648 (906) + "STATEMENT", // 649 (907) + "STEP", // 650 (908) + "STRUCTURE", // 651 (909) + "TOWARD-GREATER", // 652 (910) + "TOWARD-LESSER", // 653 (911) + "TRUNCATION", // 654 (912) + "UCS-4", // 655 (913) + "UNDERLINE", // 656 (914) + "UNSIGNED", // 657 (915) + "UTF-16", // 658 (916) + "UTF-8", // 659 (917) + "ADDRESS", // 660 (918) + "END-ACCEPT", // 661 (919) + "END-ADD", // 662 (920) + "END-CALL", // 663 (921) + "END-COMPUTE", // 664 (922) + "END-DELETE", // 665 (923) + "END-DISPLAY", // 666 (924) + "END-DIVIDE", // 667 (925) + "END-EVALUATE", // 668 (926) + "END-MULTIPLY", // 669 (927) + "END-PERFORM", // 670 (928) + "END-READ", // 671 (929) + "END-RETURN", // 672 (930) + "END-REWRITE", // 673 (931) + "END-SEARCH", // 674 (932) + "END-START", // 675 (933) + "END-STRING", // 676 (934) + "END-SUBTRACT", // 677 (935) + "END-UNSTRING", // 678 (936) + "END-WRITE", // 679 (937) + "END-IF", // 680 (938) + "THRU", // 681 (939) + "OR", // 682 (940) + "AND", // 683 (941) + "NOT", // 684 (942) + "NE", // 685 (943) + "LE", // 686 (944) + "GE", // 687 (945) + "POW", // 688 (946) + "NEG", // 689 (947) }; diff --git a/gcc/cobol/udf/stored-char-length.cbl b/gcc/cobol/udf/stored-char-length.cbl index 9ab3b14..66889d0 100644 --- a/gcc/cobol/udf/stored-char-length.cbl +++ b/gcc/cobol/udf/stored-char-length.cbl @@ -1,3 +1,6 @@ + >> PUSH source format + >>SOURCE format is fixed + * This function is in public domain. * Contributed by James K. Lowden of Cobolworx in August 2024 @@ -13,3 +16,4 @@ to Output-Value. End Function STORED-CHAR-LENGTH. + >> pop source format
\ No newline at end of file diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc index 87b19b6..aed9483 100644 --- a/gcc/cobol/util.cc +++ b/gcc/cobol/util.cc @@ -34,29 +34,24 @@ * header files. */ -#include "cobol-system.h" -#include "coretypes.h" -#include "tree.h" +#include <cobol-system.h> +#include <coretypes.h> +#include <tree.h> #undef yy_flex_debug #include <langinfo.h> -#include "coretypes.h" -#include "version.h" -#include "demangle.h" -#include "intl.h" -#include "backtrace.h" -#include "diagnostic.h" -#include "diagnostic-color.h" -#include "diagnostic-url.h" -#include "diagnostic-metadata.h" -#include "diagnostic-path.h" -#include "edit-context.h" -#include "selftest.h" -#include "selftest-diagnostic.h" -#include "opts.h" +#include <coretypes.h> +#include <version.h> +#include <demangle.h> +#include <intl.h> +#include <backtrace.h> +#include <diagnostic.h> +#include <opts.h> #include "util.h" + #include "cbldiag.h" +#include "cdfval.h" #include "lexio.h" #include "../../libgcobol/ec.h" @@ -65,6 +60,7 @@ #include "inspect.h" #include "../../libgcobol/io.h" #include "genapi.h" +#include "genutil.h" #pragma GCC diagnostic ignored "-Wunused-result" #pragma GCC diagnostic ignored "-Wmissing-field-initializers" @@ -89,19 +85,185 @@ static inline char * get_current_dir_name () { /* Use libiberty's allocator here. */ - char *buf = (char *) xmalloc (PATH_MAX); + char *buf = static_cast<char *>(xmalloc (PATH_MAX)); return getcwd (buf, PATH_MAX); } #endif +/* + * For printing messages, usually the size of the thing is some kind of string + * length, and doesn't really need a size_t. For message formatting, use a + * simple unsigned long, and warn if that's no good. "gb4" here stands for + * "4 Gigabytes". + */ +unsigned long +gb4( size_t input ) { + if( input != static_cast<unsigned long>(input) ) { + yywarn("size too large to print: %lx:%lx", + (unsigned long)(input >> (4 * sizeof(unsigned long))), + static_cast<unsigned long>(input)); + } + return input; +} + +/* + * Most CDF Directives -- those that have state -- can be pushed and popped. + * This class maintains stacks of them, with each stack having a "default + * value" that may be updated, without push/pop, via a CDF directive or + * command-line option. A push to a stack pushes the default value onto it; a + * pop copies the top of the stack to the default value. + * + * Supported: + * CALL-CONVENTION + * COBOL-WORDS + * DEFINE + * DISPLAY + * IF + * POP + * PUSH + * SOURCE FORMAT + * TURN + * not supported + * EVALUATE + * FLAG-02 + * FLAG-14 + * LEAP-SECOND + * LISTING + * PAGE + * PROPAGATE + * REF-MOD-ZERO-LENGTH + * + * >>PUSH ALL calls the class's push() method. + * >>POP ALL calls the class's pop() method. + */ +class cdf_directives_t +{ + template <typename T> + class cdf_stack_t : private std::stack<T> { // cppcheck-suppress noConstructor + T default_value; + const T& top() const { return std::stack<T>::top(); } + bool empty() const { return std::stack<T>::empty(); } + public: + void value( const T& value ) { + T& output( empty()? default_value : std::stack<T>::top() ); // cppcheck-suppress constVariableReference + output = value; + dbgmsg("cdf_directives_t::%s: %s", __func__, str(output).c_str()); + } + T& value() { + return empty()? default_value : std::stack<T>::top(); + } + void push() { + std::stack<T>::push(value()); + dbgmsg("cdf_directives_t::%s: %s", __func__, str(top()).c_str()); + } + void pop() { + if( empty() ) { + error_msg(YYLTYPE(), "CDF stack empty"); // cppcheck-suppress syntaxError + return; + } + default_value = top(); + std::stack<T>::pop(); + dbgmsg("cdf_directives_t::%s: %s", __func__, str(default_value).c_str()); + } + protected: + static std::string str(cbl_call_convention_t arg) { + char output[2] = { static_cast<char>(arg) }; + return std::string("call-convention ") + output; + } + static std::string str(current_tokens_t) { + return "<cobol-words>"; + } + static std::string str(cdf_values_t) { + return "<dictionary>"; + } + static std::string str(source_format_t arg) { + return arg.description(); + } + static std::string str(cbl_enabled_exceptions_t) { + return "<enabled_exceptions>"; + } + }; + + public: + cdf_stack_t<cbl_call_convention_t> call_convention; + cdf_stack_t<current_tokens_t> cobol_words; + cdf_stack_t<cdf_values_t> dictionary; // DEFINE + cdf_stack_t<source_format_t> source_format; + cdf_stack_t<cbl_enabled_exceptions_t> enabled_exceptions; + + cdf_directives_t() { + call_convention.value() = cbl_call_cobol_e; + } + + void push() { + call_convention.push(); + cobol_words.push(); + dictionary.push(); + source_format.push(); + enabled_exceptions.push(); + } + void pop() { + call_convention.pop(); + cobol_words.pop(); + dictionary.pop(); + source_format.pop(); + enabled_exceptions.pop(); + } +}; +static cdf_directives_t cdf_directives; + +void +current_call_convention( cbl_call_convention_t convention) { + cdf_directives.call_convention.value(convention); +} +cbl_call_convention_t +current_call_convention() { + return cdf_directives.call_convention.value(); +} + +current_tokens_t& +cdf_current_tokens() { + return cdf_directives.cobol_words.value(); +} + +cdf_values_t& +cdf_dictionary() { + return cdf_directives.dictionary.value(); +} + +void +cobol_set_indicator_column( int column ) { + cdf_directives.source_format.value().indicator_column_set(column); +} +source_format_t& cdf_source_format() { + return cdf_directives.source_format.value(); +} + +cbl_enabled_exceptions_t& +cdf_enabled_exceptions() { + return cdf_directives.enabled_exceptions.value(); +} + +void cdf_push() { cdf_directives.push(); } +void cdf_push_call_convention() { cdf_directives.call_convention.push(); } +void cdf_push_current_tokens() { cdf_directives.cobol_words.push(); } +void cdf_push_dictionary() { cdf_directives.dictionary.push(); } +void cdf_push_enabled_exceptions() { cdf_directives.enabled_exceptions.push(); } +void cdf_push_source_format() { cdf_directives.source_format.push(); } + +void cdf_pop() { cdf_directives.pop(); } +void cdf_pop_call_convention() { cdf_directives.call_convention.pop(); } +void cdf_pop_current_tokens() { cdf_directives.cobol_words.pop(); } +void cdf_pop_dictionary() { cdf_directives.dictionary.pop(); } +void cdf_pop_enabled_exceptions() { cdf_directives.enabled_exceptions.pop(); } +void cdf_pop_source_format() { cdf_directives.source_format.pop(); } + const char * symbol_type_str( enum symbol_type_t type ) { switch(type) { case SymFilename: return "SymFilename"; - case SymFunction: - return "SymFunction"; case SymField: return "SymField"; case SymLabel: @@ -115,7 +277,7 @@ symbol_type_str( enum symbol_type_t type ) case SymDataSection: return "SymDataSection"; } - dbgmsg("%s:%d: invalid symbol_type_t %d", __func__, __LINE__, type); + cbl_internal_error("%s:%d: invalid %<symbol_type_t%> %d", __func__, __LINE__, type); return "???"; } @@ -164,7 +326,7 @@ cbl_field_type_str( enum cbl_field_type_t type ) case FldBlob: return "FldBlob"; } - dbgmsg("%s:%d: invalid symbol_type_t %d", __func__, __LINE__, type); + cbl_internal_error("%s:%d: invalid %<symbol_type_t%> %d", __func__, __LINE__, type); return "???"; } @@ -350,51 +512,50 @@ normalize_picture( char picture[] ) regmatch_t pmatch[4]; if( (erc = regcomp(preg, regex, cflags)) != 0 ) { - regerror(erc, preg, regexmsg, sizeof(regexmsg)); - dbgmsg( "%s:%d: could not compile regex: %s", __func__, __LINE__, regexmsg ); - return picture; + regerror(erc, preg, regexmsg, sizeof(regexmsg)); + dbgmsg( "%s:%d: could not compile regex: %s", __func__, __LINE__, regexmsg ); + return picture; } while( (erc = regexec(preg, picture, COUNT_OF(pmatch), pmatch, 0)) == 0 ) { - assert(pmatch[1].rm_so != -1 && pmatch[1].rm_so < pmatch[1].rm_eo); - size_t len = pmatch[1].rm_eo - pmatch[1].rm_so; - assert(len == 1); - const char *start = picture + pmatch[1].rm_so; - - assert(pmatch[2].rm_so != -2 && pmatch[2].rm_so < pmatch[2].rm_eo); - len = pmatch[2].rm_eo - pmatch[2].rm_so; - assert(len > 0); - - /* - * Overwrite e.g. A(4) with AAAA. - */ - assert(pmatch[2].rm_so == pmatch[1].rm_eo + 1); // character paren number - p = picture + pmatch[2].rm_so; - len = 0; - fmt_size_t lenf = 0; - if( 1 != sscanf(p, "%" GCC_PRISZ "u", &lenf) ) { - dbgmsg("%s:%d: no number found in '%s'", __func__, __LINE__, p); - goto irregular; - } - len = lenf; - if( len == 0 ) { - dbgmsg("%s:%d: ZERO length found in '%s'", __func__, __LINE__, p); - goto irregular; - } + assert(pmatch[1].rm_so != -1 && pmatch[1].rm_so < pmatch[1].rm_eo); + size_t len = pmatch[1].rm_eo - pmatch[1].rm_so; + assert(len == 1); + const char *start = picture + pmatch[1].rm_so; + + assert(pmatch[2].rm_so != -2 && pmatch[2].rm_so < pmatch[2].rm_eo); + len = pmatch[2].rm_eo - pmatch[2].rm_so; + assert(len > 0); + + /* + * Overwrite e.g. A(4) with AAAA. + */ + assert(pmatch[2].rm_so == pmatch[1].rm_eo + 1); // character paren number + p = picture + pmatch[2].rm_so; + len = 0; + fmt_size_t lenf = 0; + if( 1 != sscanf(p, "%" GCC_PRISZ "u", &lenf) ) { + dbgmsg("%s:%d: no number found in '%s'", __func__, __LINE__, p); + goto irregular; + } + len = lenf; + if( len == 0 ) { + dbgmsg("%s:%d: ZERO length found in '%s'", __func__, __LINE__, p); + goto irregular; + } - std::vector <char> pic(len + 1, '\0'); - memset(pic.data(), *start, len); - const char *finish = picture + pmatch[2].rm_eo, - *eopicture = picture + strlen(picture); + std::vector <char> pic(len + 1, '\0'); + memset(pic.data(), *start, len); + const char *finish = picture + pmatch[2].rm_eo, + *eopicture = picture + strlen(picture); - p = xasprintf( "%*s%s%*s", - (int)(start - picture), picture, - pic.data(), - (int)(eopicture - finish), finish ); + p = xasprintf( "%*s%s%*s", + (int)(start - picture), picture, + pic.data(), + (int)(eopicture - finish), finish ); - free(picture); - picture = p; - continue; + free(picture); + picture = p; } assert(erc == REG_NOMATCH); @@ -465,7 +626,7 @@ is_elementary( enum cbl_field_type_t type ) case FldFloat: return true; // takes up space } - dbgmsg("%s:%d: invalid symbol_type_t %d", __func__, __LINE__, type); + cbl_internal_error("%s:%d: invalid %<symbol_type_t%> %d", __func__, __LINE__, type); return false; } @@ -777,7 +938,7 @@ symbol_field_type_update( cbl_field_t *field, bool redefine_field( cbl_field_t *field ) { - cbl_field_t *primary = symbol_redefines(field); + const cbl_field_t *primary = symbol_redefines(field); bool fOK = true; if( !primary ) return false; @@ -825,7 +986,7 @@ cbl_field_t::report_invalid_initial_value(const YYLTYPE& loc) const { // 8 or more, we need do no further testing because we assume // everything fits. if( data.capacity < 8 ) { - auto p = strchr(data.initial, symbol_decimal_point()); + const char *p = strchr(data.initial, symbol_decimal_point()); if( p && atoll(p+1) != 0 ) { error_msg(loc, "integer type %s VALUE '%s' " "requires integer VALUE", @@ -888,8 +1049,8 @@ cbl_field_t::report_invalid_initial_value(const YYLTYPE& loc) const { return TOUPPER(ch) == 'E'; } ); if( !has_exponent && data.precision() < pend - p ) { - error_msg(loc, "%s cannot represent VALUE '%s' exactly (max .%zu)", - name, data.initial, pend - p); + error_msg(loc, "%s cannot represent VALUE %qs exactly (max %c%td)", + name, data.initial, '.', pend - p); } } } @@ -947,8 +1108,7 @@ const cbl_field_t * literal_subscript_oob( const cbl_refer_t& r, size_t& isub /* output */) { // Verify literal subscripts if dimensions are correct. size_t ndim(dimensions(r.field)); - if( ndim == 0 || ndim != r.nsubscript ) return NULL; - cbl_refer_t *esub = r.subscripts + r.nsubscript; + if( ndim == 0 || ndim != r.nsubscript() ) return NULL; std::vector<cbl_field_t *> dims( ndim, NULL ); auto pdim = dims.end(); @@ -966,33 +1126,31 @@ literal_subscript_oob( const cbl_refer_t& r, size_t& isub /* output */) { * for the corresponding dimension. Return the first subscript not * meeting those criteria, if any. */ - auto p = std::find_if( r.subscripts, esub, - [&pdim]( const cbl_refer_t& r ) { + auto psub = std::find_if( r.subscripts.begin(), r.subscripts.end(), + [pdim]( const cbl_refer_t& r ) mutable { const auto& occurs((*pdim)->occurs); pdim++; return ! occurs.subscript_ok(r.field); } ); - isub = p - r.subscripts; - return p == esub? NULL : dims[isub]; + isub = psub - r.subscripts.begin(); + return psub == r.subscripts.end()? NULL : dims[isub]; } size_t cbl_refer_t::subscripts_set( const std::list<cbl_refer_t>& subs ) { - nsubscript = subs.size(); - subscripts = new cbl_refer_t[nsubscript]; - std::copy( subs.begin(), subs.end(), subscripts ); - + subscripts.clear(); + std::copy( subs.begin(), subs.end(), std::back_inserter(subscripts) ); return dimensions(field); } const char * cbl_refer_t::str() const { - static char subscripts[64]; - sprintf(subscripts, "(%u of " HOST_SIZE_T_PRINT_UNSIGNED " dimensions)", - nsubscript, (fmt_size_t)dimensions(field)); + static char subscripts_l[64]; + sprintf(subscripts_l, "(%u of " HOST_SIZE_T_PRINT_UNSIGNED " dimensions)", + nsubscript(), (fmt_size_t)dimensions(field)); char *output = xasprintf("%s %s %s", field? field_str(field) : "(none)", - 0 < dimensions(field)? subscripts : "", + 0 < dimensions(field)? subscripts_l : "", is_refmod_reference()? "(refmod)" : "" ); return output; } @@ -1005,18 +1163,18 @@ cbl_refer_t::name() const { const char * cbl_refer_t::deref_str() const { - std::vector<char> dimstr(nsubscript * 16, '\0'); + std::vector<char> dimstr(nsubscript() * 16, '\0'); dimstr.at(0) = '('; auto p = dimstr.begin() + 1; if( !field ) return name(); - for( auto sub = subscripts; sub < subscripts + nsubscript; sub++ ) { - auto initial = sub->field->data.initial ? sub->field->data.initial : "?"; + for( const auto& sub : subscripts ) { + auto initial = sub.field->data.initial ? sub.field->data.initial : "?"; size_t len = dimstr.end() - p; p += snprintf( &*p, len, "%s ", initial ); } - if( 0 < nsubscript ) { + if( ! subscripts.empty() ) { *--p = ')'; } char *output = xasprintf("%s%s", field->name, dimstr.data()); @@ -1093,10 +1251,8 @@ valid_move( const struct cbl_field_t *tgt, const struct cbl_field_t *src ) static_assert(sizeof(matrix[0]) == COUNT_OF(matrix[0]), "matrix should be square"); - for( const cbl_field_t *args[] = {tgt, src}, **p=args; - p < args + COUNT_OF(args); p++ ) { - auto& f(**p); - switch(f.type) { + for( auto field : { src, tgt } ) { + switch(field->type) { case FldClass: case FldConditional: case FldIndex: @@ -1108,9 +1264,9 @@ valid_move( const struct cbl_field_t *tgt, const struct cbl_field_t *src ) case FldForward: case FldBlob: default: - if( sizeof(matrix[0]) < f.type ) { + if( sizeof(matrix[0]) < field->type ) { cbl_internal_error("logic error: MOVE %s %s invalid type:", - cbl_field_type_str(f.type), f.name); + cbl_field_type_str(field->type), field->name); } break; } @@ -1368,7 +1524,7 @@ public: { assert(isym); } - procdef_t( const procref_base_t& ref ) + explicit procdef_t( const procref_base_t& ref ) : procref_base_t(ref) , isym(0) {} @@ -1377,13 +1533,6 @@ public: return procref_base_t(*this) < procref_base_t(that); } - bool operator<( const procref_base_t& that ) const { - if( that.has_section() ) { - return procref_base_t(*this) < that; - } - return strcasecmp(paragraph(), that.paragraph()) < 0; - } - cbl_label_t * label_of() const { return isym == 0? NULL : cbl_label_of(symbol_at(isym)); } @@ -1414,7 +1563,7 @@ static procedures_t::iterator current_procedure = programs.end()->second.end(); class procedure_match { const procref_base_t& ref; public: - procedure_match( const procref_base_t& ref ) : ref(ref) {} + explicit procedure_match( const procref_base_t& ref ) : ref(ref) {} // Match a 2-name reference to section & paragraph, else to one or the other. bool operator()( procedures_t::const_reference elem ) { const procdef_t& key = elem.first; @@ -1442,7 +1591,7 @@ locally_unique( size_t program, const procdef_t& key, const procref_t& ref ) { const char *section_name = ref.has_section()? ref.section() : key.section(); procref_base_t full_ref(section_name, ref.paragraph()); - return 1 == procedures.count(full_ref); + return 1 == procedures.count(procdef_t(full_ref)); } // Add each section and paragraph to the map as it occurs in the Cobol text. @@ -1504,9 +1653,9 @@ ambiguous_reference( size_t program ) { if( proc.second.end() != ambiguous ) { if( yydebug ) { dbgmsg("%s: %s of '%s' has " HOST_SIZE_T_PRINT_UNSIGNED - "potential matches", __func__, - ambiguous->paragraph(), ambiguous->section(), - (fmt_size_t)procedures.count(*ambiguous)); + "potential matches", __func__, + ambiguous->paragraph(), ambiguous->section(), + (fmt_size_t)procedures.count(procdef_t(*ambiguous))); } return new procref_t(*ambiguous); } @@ -1533,7 +1682,7 @@ intradeclarative_reference() { class next_group { size_t isym; public: - next_group( symbol_elem_t *group ) : isym(symbol_index(group)) {} + explicit next_group( const symbol_elem_t *group ) : isym(symbol_index(group)) {} // return true if elem is not a member of the group bool operator()( const symbol_elem_t& elem ) { @@ -1580,7 +1729,7 @@ public: static bool any_redefines( const cbl_field_t& field, const symbol_elem_t *group ) { for( const cbl_field_t *f = &field; f && f->parent > 0; f = parent_of(f) ) { - symbol_elem_t *e = symbol_at(f->parent); + const symbol_elem_t *e = symbol_at(f->parent); if( e == group || e->type != SymField ) break; if( symbol_redefines(f) ) return true; } @@ -1703,12 +1852,13 @@ date_time_fmt( const char input[] ) { { regex_t(), 'd', "^(" DATE_FMT_B "|" DATE_FMT_E ")$" }, { regex_t(), 't', "^(" TIME_FMT_B "|" TIME_FMT_E ")$" }, }; - int erc, cflags = REG_EXTENDED | REG_ICASE, eflags=0; + int cflags = REG_EXTENDED | REG_ICASE, eflags=0; regmatch_t m[5]; char result = 0; if( ! compiled ) { for( auto& fmt : fmts ) { + int erc; if( (erc = regcomp(&fmt.reg, fmt.pattern, cflags)) != 0 ) { char msg[80]; regerror(erc, &fmt.reg, msg, sizeof(msg)); @@ -1741,11 +1891,10 @@ struct input_file_t { ino_t inode; int lineno; const char *name; - const line_map *lines; input_file_t( const char *name, ino_t inode, - int lineno=1, const line_map *lines = NULL ) - : inode(inode), lineno(lineno), name(name), lines(lines) + int lineno=1 ) + : inode(inode), lineno(lineno), name(name) { if( inode == 0 ) inode_set(); } @@ -1764,14 +1913,29 @@ struct input_file_t { class unique_stack : public std::stack<input_file_t> { + friend void cobol_set_pp_option(int opt); + bool option_m; + std::set<std::string> all_names; + + const char * + no_wd( const char *wd, const char *name ) { + int i; + for( i=0; wd[i] == name[i]; i++ ) i++; + if( wd[i] == '\0' && name[i] == '/' ) i++; + return yydebug? name : name + i; + } + public: + unique_stack() : option_m(false) {} + bool push( const value_type& value ) { auto ok = std::none_of( c.cbegin(), c.cend(), - [value]( auto& that ) { + [value]( const auto& that ) { return value == that; } ); if( ok ) { std::stack<input_file_t>::push(value); + all_names.insert(value.name); return true; } size_t n = c.size(); @@ -1786,18 +1950,35 @@ class unique_stack : public std::stack<input_file_t> (fmt_size_t)(c.size() - --n), v.lineno, no_wd(wd, v.name) ); } } else { - dbgmsg("unable to get current working directory: %m"); + dbgmsg("unable to get current working directory: %s", xstrerror(errno)); } free(wd); } return false; } - const char * - no_wd( const char *wd, const char *name ) { - int i; - for( i=0; wd[i] == name[i]; i++ ) i++; - if( wd[i] == '\0' && name[i] == '/' ) i++; - return yydebug? name : name + i; + + // Look down into the stack. peek(0) == top() + const input_file_t& peek( size_t n ) const { + gcc_assert( n < size() ); + return c.at(size() - ++n); + } + + void option( int opt ) { // capture other preprocessor options eventually + assert(opt == 'M'); + option_m = true; + } + int option() const { + return option_m? 'M' : 0; + } + + void print() const { + std::string input( top().name ); + printf( "%s: ", input.c_str() ); + for( const auto& name : all_names ) { + if( name != input ) + printf( "\\\n\t%s ", name.c_str() ); + } + printf("\n"); } }; @@ -1806,6 +1987,12 @@ static unique_stack input_filenames; static std::map<std::string, ino_t> old_filenames; static const unsigned int sysp = 0; // not a C header file, cf. line-map.h +void cobol_set_pp_option(int opt) { + // capture other preprocessor options eventually + assert(opt == 'M'); + input_filenames.option_m = true; +} + /* * Maintain a stack of input filenames. Ensure the files are unique (by * inode), to prevent copybook cycles. Before pushing a new name, Record the @@ -1816,7 +2003,7 @@ static const unsigned int sysp = 0; // not a C header file, cf. line-map.h * to enforce uniqueness, and the scanner to maintain line numbers. */ bool cobol_filename( const char *name, ino_t inode ) { - line_map *lines = NULL; + //const line_map *lines = NULL; if( inode == 0 ) { auto p = old_filenames.find(name); if( p == old_filenames.end() ) { @@ -1826,30 +2013,49 @@ bool cobol_filename( const char *name, ino_t inode ) { } cbl_errx( "logic error: missing inode for %s", name); } - inode = p->second; - assert(inode != 0); + else { + inode = p->second; + assert(inode != 0); + } } linemap_add(line_table, LC_ENTER, sysp, name, 1); input_filename_vestige = name; - bool pushed = input_filenames.push( input_file_t(name, inode, 1, lines) ); - input_filenames.top().lineno = yylineno = 1; + bool pushed = input_filenames.push( input_file_t(name, inode, 1) ); return pushed; } const char * -cobol_lineno_save() { +cobol_lineno( int lineno ) { if( input_filenames.empty() ) return NULL; auto& input( input_filenames.top() ); - input.lineno = yylineno; + input.lineno = lineno; return input.name; } +/* + * This function is called from the scanner, usually when a copybook is on top + * of the input stack, before the parser retrieves the token and resets the + * current filename. For that reason, we normaly want to line number of the + * file that is about to become the current one, which is the one behind top(). + * + * If somehow we arrive here when there is nothing underneath, we return the + * current line nubmer, or zero if there's no input. The only consequence is + * that the reported line number might be wrong. + */ +int +cobol_lineno() { + if( input_filenames.empty() ) return 0; + size_t n = input_filenames.size() < 2? 0 : 1; + const auto& input( input_filenames.peek(n) ); + return input.lineno; +} + const char * cobol_filename() { return input_filenames.empty()? input_filename_vestige : input_filenames.top().name; } -const char * +void cobol_filename_restore() { assert(!input_filenames.empty()); const input_file_t& top( input_filenames.top() ); @@ -1857,23 +2063,52 @@ cobol_filename_restore() { input_filename_vestige = top.name; input_filenames.pop(); - if( input_filenames.empty() ) return NULL; + if( input_filenames.empty() ) return; - auto& input = input_filenames.top(); + const auto& input = input_filenames.top(); - input.lines = linemap_add(line_table, LC_LEAVE, sysp, NULL, 0); - - yylineno = input.lineno; - return input.name; + linemap_add(line_table, LC_LEAVE, sysp, NULL, 0); } -static location_t token_location; +static int first_line_minus_1 = 0; +static location_t token_location_minus_1 = 0; +static location_t token_location = 0; + +location_t current_token_location() { return token_location; } +location_t current_location_minus_one() { return token_location_minus_1; } +void current_location_minus_one_clear() + { + first_line_minus_1 = 0; + } template <typename LOC> static void gcc_location_set_impl( const LOC& loc ) { - token_location = linemap_line_start( line_table, loc.last_line, 80 ); + // Set the position to the first line & column in the location. + if( getenv("KILROY") ) + { + fprintf(stderr, "********** KILROY %d\n", loc.first_line); + } + + static location_t loc_m_1 = 0; + + token_location = linemap_line_start( line_table, loc.first_line, 80 ); token_location = linemap_position_for_column( line_table, loc.first_column); + + if( loc.first_line > first_line_minus_1 ) + { + // In order for GDB-COBOL to be able to step through COBOL code properly, + // it is sometimes necessary for the code at the beginning of a COBOL + // line to be using the location_t of the previous line. This is true, for + // example, when laying down the infrastructure code between the last + // statement of a paragraph and the code created at the beginning of the + // following paragragh. This code assumes that token_location values of + // interest are monotonic, and stores that prior value. + first_line_minus_1 = loc.first_line; + token_location_minus_1 = loc_m_1; + loc_m_1 = token_location; + } + location_dump(__func__, __LINE__, "parser", loc); } @@ -1896,11 +2131,9 @@ verify_format( const char gmsgid[] ) { static regex_t re; static int cflags = REG_EXTENDED; static int status = regcomp( &re, pattern, cflags ); - static char errbuf[80]; - - if( status != 0 ) { + static char errbuf[80]; int n = regerror(status, &re, errbuf, sizeof(errbuf)); gcc_assert(size_t(n) < sizeof(errbuf)); fprintf(stderr, "%s:%d: %s", __func__, __LINE__, errbuf); @@ -1916,9 +2149,16 @@ verify_format( const char gmsgid[] ) { } #endif -static const diagnostic_option_id option_zero; +static const diagnostics::option_id option_zero; size_t parse_error_inc(); +void gcc_location_dump() { + linemap_dump_location( line_table, token_location, stderr ); +} + + +void ydferror( const char gmsgid[], ... ) ATTRIBUTE_GCOBOL_DIAG(1, 2); + void ydferror( const char gmsgid[], ... ) { verify_format(gmsgid); @@ -1927,8 +2167,9 @@ ydferror( const char gmsgid[], ... ) { va_list ap; va_start (ap, gmsgid); rich_location richloc (line_table, token_location); - bool ret = global_dc->diagnostic_impl (&richloc, nullptr, option_zero, - gmsgid, &ap, DK_ERROR); + /*bool ret =*/ global_dc->diagnostic_impl (&richloc, nullptr, option_zero, + gmsgid, &ap, + diagnostics::kind::error); va_end (ap); } @@ -1941,7 +2182,7 @@ extern YYLTYPE yylloc; * the global token_location, which is passed to the diagnostic framework. The * original value is restored when the instantiated variable goes out of scope. */ -class temp_loc_t : protected YYLTYPE { +class temp_loc_t { location_t orig; public: temp_loc_t() : orig(token_location) { @@ -1949,14 +2190,11 @@ class temp_loc_t : protected YYLTYPE { gcc_location_set(yylloc); // use lookahead location } - temp_loc_t( const YYLTYPE& loc) : orig(token_location) { + explicit temp_loc_t( const YYLTYPE& loc) : orig(token_location) { gcc_location_set(loc); } - temp_loc_t( const YDFLTYPE& loc) : orig(token_location) { - YYLTYPE lloc = { - loc.first_line, loc.first_column, - loc.last_line, loc.last_column }; - gcc_location_set(lloc); + explicit temp_loc_t( const YDFLTYPE& loc) : orig(token_location) { + gcc_location_set(loc); } ~temp_loc_t() { if( orig != token_location ) { @@ -1986,7 +2224,8 @@ class temp_loc_t : protected YYLTYPE { va_start (ap, gmsgid); \ rich_location richloc (line_table, token_location); \ bool ret = global_dc->diagnostic_impl (&richloc, nullptr, option_zero, \ - gmsgid, &ap, DK_ERROR); \ + gmsgid, &ap, \ + diagnostics::kind::error); \ va_end (ap); \ global_dc->end_group(); @@ -1995,18 +2234,38 @@ void error_msg( const YYLTYPE& loc, const char gmsgid[], ... ) { ERROR_MSG_BODY } +void error_msg( const YDFLTYPE& loc, const char gmsgid[], ... ) + ATTRIBUTE_GCOBOL_DIAG(2, 3); + void error_msg( const YDFLTYPE& loc, const char gmsgid[], ... ) { ERROR_MSG_BODY } -void -cdf_location_set(YYLTYPE loc) { - extern YDFLTYPE ydflloc; +bool +warn_msg( const YYLTYPE& loc, const char gmsgid[], ... ) { + temp_loc_t looker(loc); + verify_format(gmsgid); + auto_diagnostic_group d; + va_list ap; + va_start (ap, gmsgid); + rich_location richloc (line_table, token_location); + auto ret = emit_diagnostic_valist( diagnostics::kind::warning, + token_location, + option_zero, gmsgid, &ap ); + va_end (ap); + return ret; +} - ydflloc.first_line = loc.first_line; - ydflloc.first_column = loc.first_column; - ydflloc.last_line = loc.last_line; - ydflloc.last_column = loc.last_column; +void error_msg_direct( const char gmsgid[], ... ) { + verify_format(gmsgid); + parse_error_inc(); + auto_diagnostic_group d; + va_list ap; + va_start (ap, gmsgid); + /*auto ret = */emit_diagnostic_valist( diagnostics::kind::error, + token_location, + option_zero, gmsgid, &ap ); + va_end (ap); } void @@ -2018,8 +2277,11 @@ yyerror( const char gmsgid[], ... ) { va_list ap; va_start (ap, gmsgid); rich_location richloc (line_table, token_location); - bool ret = global_dc->diagnostic_impl (&richloc, nullptr, option_zero, - gmsgid, &ap, DK_ERROR); + /*bool ret =*/ global_dc->diagnostic_impl ( &richloc, + nullptr, + option_zero, + gmsgid, + &ap, diagnostics::kind::error); va_end (ap); global_dc->end_group(); } @@ -2030,7 +2292,7 @@ yywarn( const char gmsgid[], ... ) { auto_diagnostic_group d; va_list ap; va_start (ap, gmsgid); - auto ret = emit_diagnostic_valist( DK_WARNING, token_location, + auto ret = emit_diagnostic_valist( diagnostics::kind::warning, token_location, option_zero, gmsgid, &ap ); va_end (ap); return ret; @@ -2062,7 +2324,7 @@ yyerrorvl( int line, const char *filename, const char fmt[], ... ) { static inline size_t matched_length( const regmatch_t& rm ) { return rm.rm_eo - rm.rm_so; } -const char * +int cobol_fileline_set( const char line[] ) { static const char pattern[] = "#line +([[:alnum:]]+) +[\"']([^\"']+). *\n"; static const int cflags = REG_EXTENDED | REG_ICASE; @@ -2075,7 +2337,7 @@ cobol_fileline_set( const char line[] ) { if( (erc = regcomp(&re, pattern, cflags)) != 0 ) { regerror(erc, &re, regexmsg, sizeof(regexmsg)); dbgmsg( "%s:%d: could not compile regex: %s", __func__, __LINE__, regexmsg ); - return line; + return 0; } preg = &re; } @@ -2083,10 +2345,10 @@ cobol_fileline_set( const char line[] ) { if( erc != REG_NOMATCH ) { regerror(erc, preg, regexmsg, sizeof(regexmsg)); dbgmsg( "%s:%d: could not compile regex: %s", __func__, __LINE__, regexmsg ); - return line; + return 0; } - error_msg(yylloc, "invalid #line directive: %s", line ); - return line; + error_msg(yylloc, "invalid %<#line%> directive: %s", line ); + return 0; } const char @@ -2095,38 +2357,39 @@ cobol_fileline_set( const char line[] ) { int fileline; if( 1 != sscanf(line_str, "%d", &fileline) ) - yywarn("could not parse line number %s from #line directive", line_str); + yywarn("could not parse line number %s from %<#line%> directive", line_str); input_file_t input_file( filename, ino_t(0), fileline ); // constructor sets inode if( input_filenames.empty() ) { - input_file.lines = linemap_add(line_table, LC_ENTER, sysp, filename, 1); input_filenames.push(input_file); } input_file_t& file = input_filenames.top(); file = input_file; - yylineno = file.lineno; - return file.name; + return file.lineno; } +//#define TIMING_PARSE +#ifdef TIMING_PARSE class cbl_timespec { - struct timespec now; + uint64_t now; // Nanoseconds public: cbl_timespec() { - clock_gettime(CLOCK_MONOTONIC, &now); + now = get_time_nanoseconds(); } double ns() const { - return now.tv_sec * 1000000000 + now.tv_nsec; + return now; } friend double operator-( const cbl_timespec& now, const cbl_timespec& then ); }; double -operator-( const cbl_timespec& then, const cbl_timespec& now ) { +operator-( const cbl_timespec& now, const cbl_timespec& then ) { return (now.ns() - then.ns()) / 1000000000; } +#endif static int parse_file( const char filename[] ) @@ -2137,15 +2400,25 @@ parse_file( const char filename[] ) parser_enter_file(filename); + if( input_filenames.option() == 'M' ) { + input_filenames.print(); + return 0; + } + +#ifdef TIMING_PARSE cbl_timespec start; +#endif int erc = yyparse(); +#ifdef TIMING_PARSE cbl_timespec finish; double dt = finish - start; + printf("Overall parse & generate time is %.6f seconds\n", dt); +#endif + parser_leave_file(); - //printf("Overall parse & generate time is %.6f seconds\n", dt); fclose (yyin); @@ -2169,30 +2442,20 @@ cobol_set_debugging( bool flex, bool yacc, bool parser ) yy_flex_debug = flex? 1 : 0; ydfdebug = yydebug = yacc? 1 : 0; f_trace_debug = parser? 1 : 0; - - char *ind = getenv("INDICATOR_COLUMN"); - if( ind ) { - int col; - if( 1 != sscanf(ind, "%d", &col) ) { - yywarn("ignored non-integer value for INDICATOR_COLUMN=%s", ind); - } - cobol_set_indicator_column(col); - } } -os_locale_t os_locale = { "UTF-8", xstrdup("C.UTF-8") }; - +os_locale_t os_locale = { "UTF-8", "C.UTF-8" }; void cobol_parse_files (int nfile, const char **files) { - char * opaque = setlocale(LC_CTYPE, ""); + const char * opaque = setlocale(LC_CTYPE, ""); if( ! opaque ) { yywarn("setlocale: unable to initialize LOCALE"); } else { char *codeset = nl_langinfo(CODESET); if( ! codeset ) { - yywarn("nl_langinfo failed after setlocale succeeded"); + yywarn("%<nl_langinfo%> failed after %<setlocale()%> succeeded"); } else { os_locale.codeset = codeset; } @@ -2227,8 +2490,11 @@ cbl_internal_error(const char *gmsgid, ...) { auto_diagnostic_group d; va_list ap; va_start(ap, gmsgid); - emit_diagnostic_valist( DK_ICE, token_location, option_zero, gmsgid, &ap ); + emit_diagnostic_valist( diagnostics::kind::ice, + token_location, option_zero, gmsgid, &ap ); va_end(ap); + abort(); // This unnecessary statement is needed so that [[noreturn]] + // // doesn't cause a warning. } void @@ -2237,7 +2503,8 @@ cbl_unimplementedw(const char *gmsgid, ...) { auto_diagnostic_group d; va_list ap; va_start(ap, gmsgid); - emit_diagnostic_valist( DK_SORRY, token_location, option_zero, gmsgid, &ap ); + emit_diagnostic_valist( diagnostics::kind::sorry, + token_location, option_zero, gmsgid, &ap ); va_end(ap); } @@ -2247,7 +2514,8 @@ cbl_unimplemented(const char *gmsgid, ...) { auto_diagnostic_group d; va_list ap; va_start(ap, gmsgid); - emit_diagnostic_valist( DK_SORRY, token_location, option_zero, gmsgid, &ap ); + emit_diagnostic_valist( diagnostics::kind::sorry, + token_location, option_zero, gmsgid, &ap ); va_end(ap); } @@ -2258,12 +2526,13 @@ cbl_unimplemented_at( const YYLTYPE& loc, const char *gmsgid, ... ) { auto_diagnostic_group d; va_list ap; va_start(ap, gmsgid); - emit_diagnostic_valist( DK_SORRY, token_location, option_zero, gmsgid, &ap ); + emit_diagnostic_valist( diagnostics::kind::sorry, + token_location, option_zero, gmsgid, &ap ); va_end(ap); } -/* - * analogs to err(3) and errx(3). +/* + * analogs to err(3) and errx(3). */ #pragma GCC diagnostic push @@ -2275,7 +2544,8 @@ cbl_err(const char *fmt, ...) { verify_format(gmsgid); va_list ap; va_start(ap, fmt); - emit_diagnostic_valist( DK_FATAL, token_location, option_zero, gmsgid, &ap ); + emit_diagnostic_valist( diagnostics::kind::fatal, + token_location, option_zero, gmsgid, &ap ); va_end(ap); } #pragma GCC diagnostic pop @@ -2286,7 +2556,8 @@ cbl_errx(const char *gmsgid, ...) { auto_diagnostic_group d; va_list ap; va_start(ap, gmsgid); - emit_diagnostic_valist( DK_FATAL, token_location, option_zero, gmsgid, &ap ); + emit_diagnostic_valist( diagnostics::kind::fatal, + token_location, option_zero, gmsgid, &ap ); va_end(ap); } @@ -2304,7 +2575,7 @@ dbgmsg(const char *msg, ...) { void dialect_error( const YYLTYPE& loc, const char term[], const char dialect[] ) { - error_msg(loc, "%s is not ISO syntax, requires -dialect %s", + error_msg(loc, "%s is not ISO syntax, requires %<-dialect %s%>", term, dialect); } @@ -2315,7 +2586,7 @@ bool fisdigit(int c) bool fisspace(int c) { return ISSPACE(c); - }; + } int ftolower(int c) { return TOLOWER(c); @@ -2327,7 +2598,7 @@ int ftoupper(int c) bool fisprint(int c) { return ISPRINT(c); - }; + } // 8.9 Reserved words static const std::set<std::string> reserved_words = { @@ -2398,7 +2669,7 @@ static const std::set<std::string> reserved_words = { "VOLATILE", "XML", "END-START", - + // ISO 2023 keywords "ACCEPT", "ACCESS", diff --git a/gcc/cobol/util.h b/gcc/cobol/util.h index 20d735d..d478ea2 100644 --- a/gcc/cobol/util.h +++ b/gcc/cobol/util.h @@ -31,11 +31,13 @@ #ifndef _UTIL_H_ #define _UTIL_H_ -void cbl_message(int fd, const char *format_string, ...); -void cbl_internal_error(const char *format_string, ...); +void cbl_message(int fd, const char *format_string, ...) + ATTRIBUTE_PRINTF_2; +[[noreturn]] void cbl_internal_error(const char *format_string, ...) + ATTRIBUTE_GCOBOL_DIAG(1, 2); -void cbl_err(const char *format_string, ...); -void cbl_errx(const char *format_string, ...); +void cbl_err(const char *format_string, ...) ATTRIBUTE_GCOBOL_DIAG(1, 2); +void cbl_errx(const char *format_string, ...) ATTRIBUTE_GCOBOL_DIAG(1, 2); bool fisdigit(int c); bool fisspace(int c); @@ -43,8 +45,84 @@ int ftolower(int c); int ftoupper(int c); bool fisprint(int c); -const char * cobol_filename_restore(); -const char * cobol_lineno_save(); +void cobol_set_pp_option(int opt); +void cobol_filename_restore(); +const char * cobol_lineno( int ); +int cobol_lineno(void); + +unsigned long gb4( size_t input ); + +template <typename P> +static inline const void * +as_voidp( P p ) { + return static_cast<const void *>(p); +} + +/* + * The default source format, whether free or fixed, is determined + * heuristically by examining the PROGRAM-ID line, if it exists, in the first + * input file. If that file does not have such a line, the default is free + * format. Else the format is set to fixed if anything appears on that line + * that would prohibit parsing it as free format, + */ +class source_format_t { + bool first_file, explicitly; + int left, right; +public: + source_format_t() + : first_file(true), explicitly(false), left(0), right(0) + {} + void indicator_column_set( int column ) { + explicitly = true; + if( column == 0 ) right = 0; + if( column < 0 ) { + column = -column; + right = 73; + } + left = column; + } + + bool inference_pending() { + bool tf = first_file && !explicitly; + first_file = false; + return tf; + } + + void infer( const char *bol, bool want_reference_format ); + + inline bool is_fixed() const { return left == 7; } + inline bool is_reffmt() const { return is_fixed() && right == 73; } + inline bool is_free() const { return ! is_fixed(); } + + const char * description() const { + if( is_reffmt() ) return "REFERENCE"; + if( is_fixed() ) return "FIXED"; + if( is_free() ) return "FREE"; + gcc_unreachable(); + } + + inline int left_margin() { + return left == 0? left : left - 1; + } + inline int right_margin() { + return right == 0? right : right - 1; + } +}; + + +void cdf_push(); +void cdf_push_call_convention(); +void cdf_push_current_tokens(); +void cdf_push_dictionary(); +void cdf_push_enabled_exceptions(); +void cdf_push_source_format(); + +void cdf_pop(); +void cdf_pop_call_convention(); +void cdf_pop_current_tokens(); +void cdf_pop_dictionary(); +void cdf_pop_source_format(); +void cdf_pop_enabled_exceptions(); #endif |