diff options
Diffstat (limited to 'gcc/cobol')
42 files changed, 4532 insertions, 3287 deletions
diff --git a/gcc/cobol/ChangeLog b/gcc/cobol/ChangeLog index 87aeaba..4b05399 100644 --- a/gcc/cobol/ChangeLog +++ b/gcc/cobol/ChangeLog @@ -1,3 +1,705 @@ +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..e884212 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: 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..548b0f2 100644 --- a/gcc/cobol/cbldiag.h +++ b/gcc/cobol/cbldiag.h @@ -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 @@ -79,23 +79,26 @@ struct YDFLTYPE #endif // 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); 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; @@ -106,7 +109,7 @@ void gcc_location_set( const YYLTYPE& loc ); template <typename LOC> static void location_dump( const char func[], int line, const char tag[], const LOC& loc) { - extern int yy_flex_debug; + extern int yy_flex_debug; // cppcheck-suppress shadowVariable if( yy_flex_debug && gcobol_getenv("update_location") ) fprintf(stderr, "%s:%d: %s location (%d,%d) to (%d,%d)\n", func, line, tag, 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..3344271 100644 --- a/gcc/cobol/cdf.y +++ b/gcc/cobol/cdf.y @@ -185,6 +185,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> @@ -262,8 +263,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; } ; @@ -364,13 +365,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"); } } ; @@ -429,7 +432,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); } } ; @@ -516,7 +519,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 +533,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); } @@ -566,7 +569,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 +587,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 +595,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; } } ; @@ -864,7 +867,7 @@ static int ydflex(void) { } bool -cdf_value( const char name[], cdfval_t value ) { +cdf_value( const char name[], const cdfval_t& value ) { auto p = dictionary.find(name); if( p != dictionary.end() ) return false; @@ -894,5 +897,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..465bdbb 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,6 @@ 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 ); #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..4bd79f1 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; @@ -568,7 +571,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..aa3fa58 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, @@ -88,10 +87,10 @@ namespace dts { static const char msg[] = "input not NUL-terminated"; throw std::domain_error( msg ); #else - eoinput = strchr(input, '\0'); + // eoinput terminates input + eoinput = strchr(input, '\0'); // cppcheck-suppress uselessAssignmentPtrArg #endif } - if( eoinput == NULL ) eoinput = strchr(input, '\0'); auto ncm = re.size(); cm.resize(ncm); std::vector <regmatch_t> cms(ncm); diff --git a/gcc/cobol/except.cc b/gcc/cobol/except.cc index 2118233..60b8416 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,11 +77,11 @@ 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; @@ -99,23 +99,25 @@ cbl_enabled_exceptions_t::dump() const { } int i = 1; for( auto& elem : *this ) { - dbgmsg("cbl_enabled_exceptions_t: %2d {%s, %s, %zu}", + 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 +135,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 +246,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 +255,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 +277,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 +322,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..01c75dd 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,24 +119,29 @@ $0 recognizes the following GnuCOBOL cobc compilation options: --fixed -F, --free -fimplicit-init - -h, --help - -save-temps= - -save-temps - -std=mvs - -std=mf -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. + -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. To see the constructed cobc command-line, use -echo. To override the default cobc, set the "cobc" environment variable. By default, gcobc invokes the gcobol the same directory the gcobc resides. To override, set the gcobol environment variable. -EOF -} + EOF + } -# -# 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). +dialect="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). # for opt in "$@" @@ -147,41 +159,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 +382,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 +435,35 @@ 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 | -std=mf-strict) dialect=mf ;; - -std=mf) opts="$opts -dialect mf" + -std=default) dialect=gnu # that's GnuCOBOL's default and GCC's dialect for GnuCOBOL + ;; + -std=cobol*) dialect="" # GCC COBOL targets COBOL2024 "mostly backward to COBOL85" + ;; + -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" ;; @@ -449,12 +482,13 @@ do *) if [ -z "$output_name" ] # first non-option argument is source file name 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" diff --git a/gcc/cobol/gcobol.1 b/gcc/cobol/gcobol.1 index 0c3d2c1..6db5400 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 ... @@ -1088,7 +1086,7 @@ 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 @@ -1167,54 +1165,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 +1292,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 +1323,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 +1359,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..70784d7 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; diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 70df86a..8017788 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -60,7 +60,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 +81,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 @@ -123,8 +126,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 +143,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 // @@ -199,7 +202,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 ) { @@ -265,11 +268,22 @@ build_main_that_calls_something(const char *something) gg_set_current_line_number(DEFAULT_LINE_NUMBER); - gg_define_function( INT, - "main", - INT, "argc", - build_pointer_type(CHAR_P), "argv", - NULL_TREE); + tree function_decl = gg_define_function( INT, + "main", + "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 @@ -569,7 +583,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 @@ -692,30 +706,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,10 +753,14 @@ 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 @@ -746,7 +776,7 @@ 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"); @@ -758,20 +788,27 @@ 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, +function_pointer_from_name(cbl_refer_t &name, tree function_return_type) { Analyze(); @@ -780,70 +817,71 @@ 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. - - // 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 fndecl_type = build_varargs_function_type_array( function_return_type, + 0, // No parameters yet + NULL); // And, hence, no types - 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 @@ -877,11 +915,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,8 +971,20 @@ 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 ) { + if( ecs.empty() ) + { + SHOW_IF_PARSE(nullptr) + { + SHOW_PARSE_HEADER + SHOW_PARSE_TEXT("ecs is empty"); + SHOW_PARSE_END + } + return NULL_TREE; + } + char ach[32]; static int counter = 1; sprintf(ach, "_ecs_table_%d", counter++); @@ -943,7 +993,8 @@ tree parser_compile_ecs( const std::vector<uint64_t>& ecs ) { 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 } @@ -951,7 +1002,8 @@ tree parser_compile_ecs( const std::vector<uint64_t>& ecs ) { 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 +1020,102 @@ 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 ) { + if( dcls.empty() ) + { + SHOW_IF_PARSE(nullptr) + { + SHOW_PARSE_HEADER + SHOW_PARSE_TEXT("dcls is empty"); + SHOW_PARSE_END + } + return NULL_TREE; + } + char ach[32]; 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 +1131,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,11 +1140,40 @@ 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 } + 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 = enabled_exceptions.size() ; + + if( !exception_processing ) + { + exception_processing = file_ops.find(statement_name) != file_ops.end(); + } + if( gg_get_current_line_number() == DEFAULT_LINE_NUMBER ) { // This code is intended to prevert GDB anomalies when the first line of a @@ -1036,16 +1182,22 @@ parser_statement_begin( const cbl_name_t statement_name, tree ecs, tree dcls ) gg_assign(var_decl_nop, build_int_cst_type(INT, 106)); } - store_location_stuff(statement_name); + // 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. + + if( exception_processing ) + { + store_location_stuff(statement_name); + } + gg_set_current_line_number(CURRENT_LINE_NUMBER); - 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 ) + { + set_exception_environment(ecs, dcls); + } + sv_is_i_o = false; } static void @@ -1203,7 +1355,7 @@ initialize_variable_internal( cbl_refer_t refer, 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 +1376,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 +1406,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 +1571,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 ) @@ -1516,42 +1668,28 @@ 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)); 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 +1792,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 ); @@ -1947,8 +2085,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(); @@ -2343,10 +2481,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 +2515,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 +2550,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; } @@ -2429,8 +2567,8 @@ combined_name(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 ) @@ -2453,7 +2591,7 @@ combined_name(cbl_label_t *label) static char *retval= (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 ) @@ -3169,8 +3307,8 @@ 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); @@ -3347,7 +3485,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 ) @@ -3497,8 +3635,6 @@ parser_first_statement( int lineno ) } } -#define linemap_add(...) - void parser_enter_file(const char *filename) { @@ -3530,9 +3666,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 +3738,22 @@ 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. + gg_leaving_the_source_code_file(); + } } void @@ -3629,15 +3768,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 +3802,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 +3861,31 @@ 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_); + + char *mangled_name; + + if( current_call_convention() == cbl_call_cobol_e ) + { + mangled_name = cobol_name_mangler(funcname_); + } + else + { + mangled_name = xstrdup(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); @@ -3802,6 +3951,8 @@ parser_enter_program( const char *funcname_, TRACE1_TEXT("\"") TRACE1_END } + + free(funcname); } void @@ -3997,7 +4148,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'); @@ -5107,7 +5258,7 @@ parser_display_field(cbl_field_t *field) * 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. + * that need special care and feeding. */ void parser_display( const struct cbl_special_name_t *upon, @@ -5169,6 +5320,18 @@ parser_display( const struct cbl_special_name_t *upon, gg_assign(file_descriptor, integer_two_node); break; + case ENV_NAME_e: + // This Part I of the slightly absurd method of using DISPLAY...UPON + // to fetch, or set, environment variables. + 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; + default: if( upon->os_filename[0] ) { @@ -5549,16 +5712,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 @@ -5859,7 +6022,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 +6075,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 +6103,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 +6122,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,7 +6133,7 @@ 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; } @@ -6012,7 +6177,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 +6200,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. @@ -6103,7 +6265,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 +6302,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 +6313,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 +6338,7 @@ parser_exit( cbl_refer_t refer, ec_type_t ec ) { } ENDIF - pe_stuff(refer, ec); + program_end_stuff(refer, ec); } } @@ -6667,7 +6829,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 +6850,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() @@ -6784,7 +6950,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++) { @@ -7114,20 +7280,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 +7399,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 +7463,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 +7509,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); } @@ -7594,20 +7760,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; } @@ -7660,9 +7825,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() ) { @@ -7799,12 +7964,13 @@ parser_perform_conditional( struct cbl_perform_tgt_t *tgt ) 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); @@ -7848,7 +8014,7 @@ parser_perform_conditional_end( struct cbl_perform_tgt_t *tgt ) 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 @@ -8924,7 +9090,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 +9202,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 +9327,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 +9401,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 +9448,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 +9481,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 +9501,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 +9551,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 +9582,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 +9670,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 +9724,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", @@ -9620,6 +9794,7 @@ parser_file_delete( struct cbl_file_t *file, bool /*sequentially*/ ) SHOW_PARSE_END } + sv_is_i_o = true; store_location_stuff("DELETE"); gg_call(VOID, "__gg__file_delete", @@ -9676,6 +9851,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", @@ -9785,6 +9961,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", @@ -9799,14 +9976,52 @@ 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) + 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 +10031,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 +10045,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 +10060,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 +10096,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 +10116,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 +10163,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 +10171,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) + cbl_inspect_opers_t& operations) { Analyze(); // This is an INSPECT FORMAT 2 @@ -9968,6 +10187,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 +10198,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 +10219,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 +10233,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 +10254,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 +10267,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 +10296,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 +10312,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 +10332,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 +10348,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 +10365,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 +10376,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 +10391,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); } } @@ -10320,10 +10539,11 @@ 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)); + std::vector<cbl_refer_t> arg1(argc); + std::vector<cbl_refer_t> arg2(argc); for(size_t i=0; i<argc; i++) { @@ -10339,8 +10559,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 +10574,6 @@ parser_intrinsic_subst( cbl_field_t *f, gg_free(control); - free(arg2); - free(arg1); free(control_bytes); } @@ -10449,7 +10667,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 +10724,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), @@ -10822,7 +11042,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); @@ -11059,7 +11279,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,7 +11368,7 @@ 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; @@ -11169,7 +11389,7 @@ is_ascending_key(cbl_refer_t key) { 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 +11515,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 +11533,22 @@ 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 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 = (const_field_t *)xmalloc(total_keys * sizeof(cbl_field_t *)); size_t *flattened_ascending = (size_t *)xmalloc(total_keys * sizeof(size_t)); 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 +11557,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 +11597,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 +11661,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 +11674,18 @@ 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 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 = (const_field_t *)xmalloc(total_keys * sizeof(cbl_field_t *)); size_t *flattened_ascending = (size_t *) xmalloc(total_keys * sizeof(size_t)); 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 +11694,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 +11791,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__); } } @@ -11777,8 +11997,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 +12020,19 @@ 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 = (const_field_t *)xmalloc(total_keys * sizeof(cbl_field_t *)); size_t *flattened_ascending = (size_t *)xmalloc(total_keys * sizeof(size_t)); 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 +12041,8 @@ 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); @@ -11890,7 +12109,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 +12203,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__); } } @@ -12062,7 +12281,7 @@ 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)); + std::vector<cbl_refer_t> delims(ndelimited); char *alls = (char *)xmalloc(ndelimited+1); for(size_t i=0; i<ndelimited; i++) @@ -12074,7 +12293,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 +12317,6 @@ parser_unstring(cbl_refer_t src, NULL_TREE) ); free(alls); - free(delims); if( overflow ) { @@ -12134,12 +12352,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 { @@ -12165,7 +12383,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 +12408,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 +12418,6 @@ parser_string( cbl_refer_t tgt, gg_free(pintegers); free(integers); - free(refers); if( overflow ) { @@ -12297,11 +12514,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; @@ -12522,28 +12739,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)); - tree call_expr = gg_call_expr_list( returned_value_type, - function_handle, + 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 ); + + // Create the call_expr from that address + call_expr = build_call_array_loc( location_from_lineno(), + 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 +12893,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 +12948,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 +13009,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) ) { - // If these conditions are true, then we know we have a good - // function_handle, and we don't need to check + // name is a literal create_and_call(narg, args, - function_handle, + NULL_TREE, + name.field->data.initial, returned_value_type, returned, - not_except - ); + not_except); + } + else if( name.field && name.field->type == FldPointer ) + { + 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_pointer, + nullptr, + returned_value_type, + returned, + 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 +13099,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 +13141,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 +13178,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 +13225,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 +13239,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 +13294,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 +13346,8 @@ typedef struct hier_node hier_node() : our_index(0), common(false), - parent_node(NULL) + parent_node(nullptr), + name(nullptr) {} } hier_node; @@ -13126,7 +13391,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 +13409,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 +13464,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 +13478,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); @@ -13287,7 +13552,7 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) // 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 +13579,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), @@ -13383,50 +13650,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 +13729,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( enabled_exceptions.size() || sv_is_i_o ) + { gg_call(VOID, "__gg__check_fatal_exception", NULL_TREE); + } } void @@ -13522,7 +13753,7 @@ parser_pop_exception() { gg_call(VOID, "__gg__exception_pop", NULL_TREE); } - + void parser_clear_exception() { @@ -13623,7 +13854,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 +13867,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) ) @@ -13957,8 +14188,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,7 +14217,7 @@ 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); @@ -14193,8 +14424,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), @@ -15469,7 +15700,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 ) ) @@ -15558,7 +15789,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) ) @@ -15626,22 +15857,19 @@ initial_from_initial(cbl_field_t *field) retval = (char *)xmalloc(field->data.capacity+1); 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 @@ -16111,14 +16339,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 +16373,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]; @@ -16153,7 +16397,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 // { @@ -16226,7 +16469,7 @@ 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); @@ -16248,7 +16491,7 @@ parser_symbol_add(struct cbl_field_t *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 +16505,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, @@ -16364,7 +16607,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 @@ -16392,7 +16635,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 +16675,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 +16882,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 +16902,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 +16949,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..36d947b 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. @@ -119,26 +119,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, @@ -225,7 +225,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 @@ -255,7 +255,7 @@ parser_end_program(const char *name=NULL); void parser_sleep(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 ); @@ -297,7 +297,7 @@ 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); @@ -315,7 +315,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 +406,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 +421,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, @@ -492,12 +489,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 +549,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..e42747b 100644 --- a/gcc/cobol/gengen.cc +++ b/gcc/cobol/gengen.cc @@ -136,6 +136,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 +265,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 +354,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 +368,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 +407,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 +418,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 +429,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 +452,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(location_from_lineno(), + MODIFY_EXPR, + TREE_TYPE(dest), + dest, + source); gg_append_statement(stmt); } else @@ -465,20 +465,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)) + // where we are.S + static const int debugging = 1; + if( debugging ) { - 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)) - { - 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 +525,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(); @@ -933,7 +937,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 @@ -2152,18 +2156,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 +2165,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 +2173,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,7 +2186,7 @@ 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(), @@ -2206,8 +2195,6 @@ gg_printf(const char *format_string, ...) nargs, args); gg_append_statement(stmt); - - gg_pop_context(); } tree @@ -2233,8 +2220,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(); } @@ -2486,123 +2472,121 @@ 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); +static std::unordered_map<std::string, tree> map_of_function_decls; - // 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::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 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 ) +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. + + 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() ) { - // 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; + // This function_decl has already been defined. + retval = TREE_TYPE(TREE_TYPE(it->second)); + } + return retval; + } + +tree +gg_build_fn_decl(const char *funcname, tree fndecl_type) + { + tree function_decl; + + 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. Just return it; the caller + // is responsible for modifying it, if necessary. + function_decl = it->second; } 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; - - // This function is file static, but nobody calls it, so without - // intervention -O1+ optimizations will discard it. - DECL_PRESERVE_P (function_decl) = 1; + // 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. - // Append this function to the list of functions and variables - // associated with the computation module. - gg_append_var_decl(function_decl); - } + function_decl = build_fn_decl(funcname, fndecl_type); - // 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; + // 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; - // 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: + DECL_PRESERVE_P (function_decl) = 0; + DECL_ARTIFICIAL(function_decl) = 0; + map_of_function_decls[key] = function_decl; + } + return function_decl; + } - allocate_struct_function(function_decl, false); +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. - 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); + // 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. - // 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++; + /* There is some bookkeeping we need to do to avoid crashing. - // With everything established, put this function_decl on the stack - gg_trans_unit.function_stack.push_back(new_function); + 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: - // All we need is a context, and we are ready to go: - gg_push_context(); - return function_decl; - } + */ -void -gg_tack_on_function_parameters(tree function_decl, ...) - { int nparams = 0; tree types[ARG_LIMIT]; const char *names[ARG_LIMIT]; va_list params; - va_start(params, function_decl); + va_start(params, unmangled_name); for(;;) { tree var_type = va_arg(params, tree); @@ -2615,10 +2599,8 @@ gg_tack_on_function_parameters(tree function_decl, ...) { // 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(); } @@ -2629,88 +2611,33 @@ gg_tack_on_function_parameters(tree function_decl, ...) 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); - // Chain the names onto the variables list: - for(int i=0; i<nparams; i++) + std::unordered_set<std::string>::const_iterator it = + names_we_have_seen.find(funcname); + if( it != names_we_have_seen.end() ) { - chain_parameter_to_function(function_decl, types[i], names[i]); + static int bum_counter = 1; + // We have seen this name before. Replace it with something unique: + char ach[32]; + sprintf(ach, "..no_dupes.%d", bum_counter++); + funcname = ach; } - } - -void -gg_define_function(tree return_type, const char *funcname, ...) - { - // 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 - - int nparams = 0; - - tree types[ARG_LIMIT]; - const char *names[ARG_LIMIT]; - - va_list params; - va_start(params,funcname); - for(;;) + else { - 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(); - } - - const char *name = va_arg(params, const char *); - - 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(); - } + names_we_have_seen.insert(funcname); } - va_end(params); - // Create the FUNCTION_TYPE for that array: 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 +2645,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); } @@ -2757,6 +2702,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 +2716,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 +2760,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 +2772,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(); } @@ -2889,63 +2847,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,8 +3052,7 @@ 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(); } @@ -3141,8 +3108,7 @@ 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(); } @@ -3179,7 +3145,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[]] @@ -3196,7 +3162,7 @@ gg_call_expr_list(tree return_type, tree function_name, int param_count, tree ar tree the_call = build_call_array_loc(location_from_lineno(), return_type, - function_name, + function_pointer, param_count, args); // This routine returns the call_expr; the caller will have to deal with it @@ -3438,8 +3404,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 *format, ...) +gg_insert_into_assembler(const char ach[]) + { + if( !optimize ) + { + // 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); + + // And insert it as a statement + gg_append_statement(asm_expr); + } + } + +void +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 +3447,8 @@ 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); - - // And insert it as a statement - gg_append_statement(asm_expr); + gg_insert_into_assembler(ach); } } + +#pragma GCC diagnostic pop
\ No newline at end of file diff --git a/gcc/cobol/gengen.h b/gcc/cobol/gengen.h index 8c1bc8d..06b28e06 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,7 +525,7 @@ 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(); +extern 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); @@ -536,9 +533,13 @@ extern int gg_get_current_line_number(); 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..0a1c12d 100644 --- a/gcc/cobol/genmath.cc +++ b/gcc/cobol/genmath.cc @@ -95,8 +95,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) @@ -137,7 +137,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 +207,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, @@ -253,9 +253,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 +304,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 +319,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 +334,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 +578,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)); } @@ -756,12 +749,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 +759,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 +986,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 +1208,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 +1231,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 +1383,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 +1446,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 +1455,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 +1697,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..1d921a3 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -107,13 +107,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 +232,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 +293,248 @@ 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 + cbl_refer_t &refer) + { + 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 ) ) + { + // 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) { - REFER; - if( getenv("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 *depending_on; + depending_on = cbl_field_of(symbol_at(odo->occurs.depending_on)); + + if( !enabled_exceptions.match(ec_bound_odo_e) ) { - fprintf(stderr, " %s %s\n", refer.field->name, refer.field->data.initial); + // 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(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 @@ -316,10 +550,9 @@ get_data_offset(cbl_refer_t &refer, 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 @@ -336,7 +569,7 @@ get_data_offset(cbl_refer_t &refer, cbl_field_t *parent = refer.field; // 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 +588,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 +599,94 @@ 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()) ) + 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 + } + } - tree augment = gg_multiply(subscript, get_any_capacity(parent)); - gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment))); + 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 + + 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 +695,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 +737,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 { @@ -1064,8 +1267,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 +1561,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 +1579,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 +1605,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; @@ -1711,18 +1914,14 @@ 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; } @@ -1734,7 +1933,7 @@ refer_is_clean(cbl_refer_t &refer) // 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 +1941,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; 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); + 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); - tree rt_capacity = get_any_capacity(refer.field); // This is a size_t + 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 ) - { - 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 + // Arrive here with a valid value for reflen: - // 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 - - 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); - - // 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: - - 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; + 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 @@ -1958,11 +2005,10 @@ refer_offset(cbl_refer_t &refer, { // 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 +2027,9 @@ refer_offset(cbl_refer_t &refer, } static -tree +tree // size_t refer_size(cbl_refer_t &refer, refer_type_t refer_type) { - REFER; Analyze(); static tree retval = gg_define_variable(SIZE_T, "..rs_retval", vs_file_static); @@ -2026,14 +2071,12 @@ refer_size(cbl_refer_t &refer, refer_type_t refer_type) tree // size_t refer_size_dest(cbl_refer_t &refer) { - REFER; return refer_size(refer, refer_dest); } tree // size_t refer_size_source(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 @@ -2074,3 +2117,26 @@ qualified_data_location(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..0d9028e 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, @@ -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..2d9fb72 100644 --- a/gcc/cobol/lexio.cc +++ b/gcc/cobol/lexio.cc @@ -123,7 +123,7 @@ 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' ) { +indicated( char *bol, const char *eol, char ch = '\0' ) { if( indicator.column == 0 && *bol != '*' ) { return NULL; // no indicator column in free format, except for comments } @@ -140,10 +140,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 +208,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 +266,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 +303,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 +320,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__, @@ -345,7 +349,7 @@ 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) ) { + if( regex_search(p, const_cast<const char *>(mfile.eol), cm, re) ) { gcc_assert(cm.size() > 1); switch( cm[3].length() ) { case 4: @@ -459,9 +463,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 +535,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 +745,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 +813,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 +881,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) @@ -928,7 +932,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 +985,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 +1012,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 +1022,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 +1077,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 +1113,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 +1151,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; @@ -1409,7 +1413,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,7 +1459,7 @@ 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)) ) { @@ -1466,7 +1470,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 +1495,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 +1524,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 +1546,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 +1560,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)", @@ -1682,7 +1689,7 @@ 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 ); /* @@ -1822,15 +1829,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(); @@ -1886,31 +1893,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 +1906,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 +1922,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()) + }; + 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 +1961,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..eb41068 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); @@ -255,12 +247,19 @@ struct span_t { auto p = std::find(this->p, pend, '\0'); return p != pend? p : 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..74637c9 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -188,14 +188,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 +242,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 ) { @@ -375,7 +375,7 @@ LSUB "(" PARAMETER_kw "PARAMETER" OVERRIDE READY RESET - RSUB ")" + RSUB")" SERVICE_RELOAD "SERVICE RELOAD" STAR_CBL "*CBL" SUBSCRIPT SUPPRESS TITLE TRACE USE @@ -662,7 +662,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 +692,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 +732,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 @@ -831,6 +831,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,6 +843,8 @@ 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; @@ -880,9 +885,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; @@ -951,7 +956,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", @@ -1320,7 +1325,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 +1351,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,6 +1458,7 @@ 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 @@ -1473,7 +1487,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; } @@ -1509,7 +1523,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() ) { @@ -1551,7 +1566,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 +1595,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] @@ -1940,7 +1955,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 +1967,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 +2036,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 +2198,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 +2305,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 +2318,8 @@ config_paragraph: } } } - | REPOSITORY '.' - | REPOSITORY '.' repo_members '.' + | REPOSITORY dot + | REPOSITORY dot repo_members '.' ; repo_members: repo_member @@ -2317,38 +2347,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 +2433,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); } ; @@ -2510,7 +2563,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; } @@ -2582,7 +2635,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 +2689,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 +2875,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 +2955,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 +2994,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 +3031,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; } @@ -3171,7 +3227,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 +3335,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; } @@ -3352,9 +3408,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 +3428,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 +3467,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,8 +3521,8 @@ 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, @@ -3602,7 +3681,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 +3723,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 +3801,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 +3934,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 +4028,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 +4094,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 +4133,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 +4212,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 +4231,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 +4245,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 +4265,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 +4320,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 +4401,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; @@ -4662,7 +4742,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 +4791,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 +4803,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 ); } } @@ -4936,12 +5016,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; } } @@ -5027,7 +5106,7 @@ 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_command_line_e: if( $1.from->field == NULL ) { // take next command-line arg @@ -5039,7 +5118,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, @@ -5236,9 +5315,19 @@ 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; + } + // Add the name now, as a convenience. + cbl_special_name_t special = { 0, *special_type }; + namcpy(@NAME, special.name, $NAME); + + symbol_elem_t *e = symbol_special_add(PROGRAM, &special); + $$ = cbl_special_name_of(e); + } + assert($$); } ; @@ -5355,16 +5444,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 +5479,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; @@ -5480,7 +5566,7 @@ display: disp_body end_display 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() ); + const cbl_refer_t& src( $1.vargs->args.front() ); cbl_field_t *dst = register_find("_ARGI"); parser_move( dst, src ); } else { @@ -5499,7 +5585,7 @@ display: disp_body end_display 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() ); + const cbl_refer_t& src( $1.vargs->args.front() ); cbl_field_t *dst = register_find("_ARGI"); parser_move( dst, src ); } else { @@ -5647,7 +5733,8 @@ end_program: end_program1[end] '.' gcc_unreachable(); } if( !matches ) { - error_msg(@end, "END %s %s' does not match IDENTIFICATION DIVISION '%s'", + error_msg(@end, "END %s %s does not match " + "%<IDENTIFICATION DIVISION %s%>", token_name, name, prog->name); YYERROR; } @@ -5659,7 +5746,7 @@ end_program: end_program1[end] '.' } 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,9 +5765,9 @@ 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; } ; @@ -5754,7 +5841,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 +6425,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 +6530,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 +6541,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; } } @@ -6731,7 +6818,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; } @@ -7004,6 +7091,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 +7210,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 +7326,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(); @@ -7472,6 +7589,7 @@ perform_inline: perform_start statements END_PERFORM } } ; + perform_start: %empty %prec LOCATION { perform_ec_setup(); $$ = 0; @@ -7498,18 +7616,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 +7634,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 +7724,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 +7738,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 +7752,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 +7894,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 +7927,10 @@ varg1a: ADDRESS OF scalar { } ; +binary_type: BINARY_INTEGER { $$ = $1.capacity; } + | COMPUTATIONAL { $$ = $1.capacity; } + ; + literal: literalism { $$ = $1.isymbol()? @@ -7854,7 +7974,7 @@ raise: RAISE EXCEPTION NAME "EXCEPTION CONDITION: %s", $NAME); YYERROR; } - cbl_unimplemented("RAISE <EXCEPTION OBJECT>"); + cbl_unimplemented("RAISE %<EXCEPTION OBJECT%>"); YYERROR; } ; @@ -7921,10 +8041,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 +8051,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 +8488,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 +8508,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 +8674,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 +8699,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 @@ -8724,14 +8839,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 +8885,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 +8895,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 +8939,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 +9131,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 +9143,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 +9155,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 +9179,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 +9205,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 +9215,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 +9237,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 +9286,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 +9332,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 +9346,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 +9362,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 +9387,7 @@ insp_quals: insp_qual { } else { $$->after = *$insp_qual.qual; } + dump_inspect_match(*$$); } | insp_quals insp_qual { @@ -9695,7 +9807,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); } @@ -10086,12 +10198,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 +10219,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 +10254,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 %zu (%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 +10271,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 +10289,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 +10347,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 +10356,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 +10367,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 +10382,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 +10404,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 +10419,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 +10434,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 +10442,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 +10536,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 +10563,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 +10578,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 +10595,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 +10617,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 +10633,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 +10649,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 +10658,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 +10675,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 +10691,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 +10700,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 +10717,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 +10733,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 +10742,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 +10750,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 +10799,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 +10879,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 +11348,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, @@ -11326,7 +11440,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,9 +11448,13 @@ 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; @@ -11380,9 +11498,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); @@ -11419,7 +11537,7 @@ keyword_tok( const char * text, bool 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 +11583,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 } @@ -11711,7 +11829,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 +11871,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 +11892,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 +11931,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 +11945,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 +12060,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 +12077,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 +12098,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 +12106,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 +12218,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 +12242,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 +12380,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 +12396,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 +12404,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 +12430,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 +12444,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 +12452,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 +12476,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 +12502,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 +12511,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 +12588,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 +12608,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 +12628,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 +12642,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 +12679,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 +12790,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 +12801,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 +12822,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 +12854,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 +12926,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 +12973,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 +13027,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 +13064,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 + 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 +13137,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 +13160,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 +13186,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 +13209,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 +13225,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 +13234,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..105afe9 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(); \ + gcc_location_set( 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); } @@ -1024,7 +1032,7 @@ class tokenset_t { const char * name_of( int tok ) const { tok -= (255 + 3); gcc_assert(0 <= tok && size_t(tok) < token_names.size()); - return token_names[tok]; + return tok < 0? "???" : token_names[tok]; } }; @@ -1035,7 +1043,7 @@ class 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 ) { + 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)) ) { @@ -1054,7 +1062,7 @@ class current_tokens_t { 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 ) { + 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)) ) { @@ -1091,7 +1099,7 @@ redefined_token( const cbl_name_t 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 +1113,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 +1148,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 +1170,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 +1203,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 +1229,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 +1260,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 +1284,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 +1306,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 +1322,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 +1398,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 +1414,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 +1442,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 +1461,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); @@ -1492,9 +1478,8 @@ class prog_descr_t { 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) @@ -1605,9 +1590,9 @@ class program_stack_t : protected std::stack<prog_descr_t> { 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; + cbl_call_convention_t call_convention = cbl_call_cobol_e; + if( !empty() ) call_convention = top().call_convention; + descr.call_convention = call_convention; std::stack<prog_descr_t>& me(*this); me.push(descr); } @@ -1643,11 +1628,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 +1641,7 @@ class program_stack_t : protected std::stack<prog_descr_t> { } return eval; } + // cppcheck-suppress-end useStlAlgorithm }; struct rel_part_t { @@ -1662,9 +1649,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 +1689,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 +1848,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 +1859,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 +1883,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 +1896,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 +1904,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 +1944,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 +1999,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 @@ -2077,7 +2075,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 +2099,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 +2112,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; @@ -2145,7 +2143,7 @@ static class current_t { 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 +2154,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 +2174,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 +2225,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 +2273,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 +2380,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; @@ -2443,10 +2455,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 +2574,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 +2622,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 +2700,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 * @@ -3142,6 +3155,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 +3193,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 +3223,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 +3253,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 +3288,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 +3317,7 @@ implicit_section() } static void +// cppcheck-suppress constParameterPointer ast_enter_exit_section( cbl_label_t * section ) { auto implicit = section? implicit_paragraph() : NULL; @@ -3368,7 +3397,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 +3407,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 +3628,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, 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..2fc4aea 100644 --- a/gcc/cobol/scan.l +++ b/gcc/cobol/scan.l @@ -79,6 +79,8 @@ nonseq (([''][[:alnum:]]+][''])|([""][[:alnum:]]+[""])) INTEGER 0*[1-9][[:digit:]]* INTEGERZ [[:digit:]]+ +NONWORD [^[:alnum:]$_-]+ + SPC [[:space:]]+ OSPC [[:space:]]* EOL \r?\n @@ -86,7 +88,7 @@ BLANK_EOL [[:blank:]]*{EOL} BLANK_OEOL [[:blank:]]*{EOL}? -DOTSEP [.][[:space:]] +DOTSEP [.]+[[:space:]] DOTEOL [[:blank:]]*[.]{BLANK_EOL} SKIP [[:blank:]]*SKIP[123][[:blank:]]*[.]?{BLANK_EOL} @@ -176,7 +178,7 @@ NL [[:blank:]]*\r?\n[[: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 @@ -270,12 +272,13 @@ PROCEDURE{SPC}DIVISION { yy_push_state(procedure_div); } <ident_state>{ + ID(ENTIFICATION)?{SPC}DIVISION { 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 { + [[:blank:]]*(ENVIRONMENT|DATA|PROCEDURE){SPC}DIVISION/[[:space:].] { yy_pop_state(); myless(0); } [[:blank:]]*AUTHOR[[:blank:].]+{EOL}? { // Might not have an EOL, but stop on one. @@ -326,6 +329,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; } @@ -856,8 +868,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; } @@ -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 @@ -1392,10 +1405,9 @@ USE({SPC}FOR)? { return USE; } <name_state>{ ^[[:blank:]]+ ^{BLANK_EOL} + {NAME} | {NAME}/{OSPC}[.] { yy_pop_state(); yylval.string = xstrdup(yytext); return NAME; } - {NAME} { yy_pop_state(); - yylval.string = xstrdup(yytext); return NAME; } Z?[''] { yylval.literal.set_prefix(yytext, yyleng-1); yy_push_state(quoted1); } @@ -1499,11 +1511,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 +1523,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 +1618,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; } @@ -1612,22 +1647,8 @@ USE({SPC}FOR)? { return USE; } 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); @@ -1795,126 +1816,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 +2032,7 @@ BASIS { yy_push_state(basis); return BASIS; } } return token; } - [.][[:blank:].]+ { return '.'; } + [.]+[[:blank:].]+ { return '.'; } } <exception>{ @@ -2107,36 +2130,42 @@ 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; } <*>[().=*/+&-] { return *yytext; } <*>[[:blank:]]+ <*>\r?\n @@ -2150,48 +2179,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 +2231,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 +2250,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,100 +2273,99 @@ 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; } @@ -2346,15 +2374,15 @@ BASIS { yy_push_state(basis); return BASIS; } 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,20 +2396,20 @@ 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; } SELECT { return SELECT; } @@ -2389,56 +2417,56 @@ BASIS { yy_push_state(basis); return BASIS; } 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 +2503,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..ea304ba 100644 --- a/gcc/cobol/scan_ante.h +++ b/gcc/cobol/scan_ante.h @@ -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(); } } @@ -368,8 +373,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 +387,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 +403,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,27 +416,61 @@ 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 ); struct { char *p, *pend; @@ -474,7 +514,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 +524,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)) ) \ @@ -571,7 +608,8 @@ binary_integer_usage( const char 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); @@ -588,6 +626,16 @@ binary_integer_usage( const char name[]) { 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 = {}; @@ -657,7 +705,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 +779,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 +793,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 +827,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 +849,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..a273da9 100644 --- a/gcc/cobol/scan_post.h +++ b/gcc/cobol/scan_post.h @@ -116,10 +116,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); } @@ -260,13 +260,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 +297,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 +374,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..db24807 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) \ { \ @@ -337,13 +337,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, " "); \ } \ @@ -424,30 +424,31 @@ extern bool cursor_at_sol; // 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(); \ - } \ +#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(); \ + } \ }while(0); #ifdef INCORPORATE_ANALYZER @@ -506,7 +507,7 @@ class ANALYZE 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..089c9c1 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -56,7 +56,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 +136,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 +158,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 +227,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 +261,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 +284,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 +454,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; @@ -947,7 +911,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 +931,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 auto 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 +942,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 +997,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 +1029,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 +1174,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 auto record = cbl_field_of(p); assert(record->level == 1); e = calculate_capacity(p); auto record_size = std::max(record->data.memsize, @@ -1383,19 +1343,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 +1366,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)); @@ -1508,7 +1467,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 +1578,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 +1707,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 +1745,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 auto redefined = symbol_redefines(field); size_invalid = ! is_record_area(redefined); } if( !field->is_valid() || size_invalid ) @@ -1854,6 +1812,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 +1828,7 @@ symbols_update( size_t first, bool parsed_ok ) { } // Verify REDEFINing field has no ODO components - auto parent = symbol_redefines(field); + const auto 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 +2018,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 +2104,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 ) { @@ -2441,7 +2408,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 +2421,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 +2466,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 auto f = cbl_field_of(e); if( f == field ) return e; } @@ -2537,7 +2504,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 +2516,7 @@ 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; field->data.initial = NULL; } } @@ -2668,6 +2635,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 +2651,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 +2714,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 +2728,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 +2836,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 +2922,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 +2960,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 +2978,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 +3088,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,7 +3137,7 @@ 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; @@ -3245,6 +3214,8 @@ new_temporary_impl( enum cbl_field_type_t type ) snprintf(f->name, sizeof(f->name), "_stack%d",++nstack); } + f->data.initial = name; // capture e.g. the function name + return f; } @@ -3263,7 +3234,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 +3243,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 +3338,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 +3375,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 +3386,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 +3493,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 +3610,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 +3705,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 +3717,27 @@ 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); + 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 +3879,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 +3908,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 +3921,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 +3930,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 +3953,6 @@ expand_picture(const char *picture) { pcurrency[i] = 'B'; } - dest_length += sign_length; } } @@ -4228,7 +4183,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 auto prog = cbl_label_of(e); if( program == symbol_index(e) && !prog->recursive ) continue; if( (self->parent == prog->parent && prog->common) || @@ -4262,6 +4217,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 +4229,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 ) { @@ -4295,24 +4252,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 +4277,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 +4295,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); } @@ -4518,11 +4470,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, @@ -4609,27 +4561,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,7 +4628,7 @@ 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 }; + const file_status_field_t *fs, key { status }; fs = (file_status_field_t*)lfind( &key, file_status_fields, &n, sizeof(*fs), cbl_file_status_cmp ); @@ -4721,7 +4658,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..0b72b5c 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() + : unique(true) + , leftmost(0) + , nfield(0) + , fields(nullptr) + { + memset(name, '\0', sizeof(name)); + } - cbl_file_key_t( size_t field = 0, bool unique = true ) + // 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,56 @@ 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; -} - 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 +1962,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 +2018,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 +2026,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 +2078,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 +2103,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 +2145,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 +2171,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 +2197,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 +2311,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 +2321,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 +2334,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 +2346,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 ); @@ -2321,8 +2396,9 @@ 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) {} @@ -2375,10 +2451,6 @@ 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 ); @@ -2393,7 +2465,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..39df2a0 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 auto 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 auto 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(), @@ -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 auto 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 auto 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; @@ -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..4b24fc6 100644 --- a/gcc/cobol/token_names.h +++ b/gcc/cobol/token_names.h @@ -691,6 +691,7 @@ tokens = { { "neg", NEG }, // 939 }; +// cppcheck-suppress useInitializationList token_names = { "IDENTIFICATION", // 0 (258) "ENVIRONMENT", // 1 (259) diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc index 87b19b6..23f605d 100644 --- a/gcc/cobol/util.cc +++ b/gcc/cobol/util.cc @@ -65,6 +65,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" @@ -94,14 +95,28 @@ get_current_dir_name () } #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; +} + 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 +130,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 +179,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 +365,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 +479,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 +791,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 +839,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 auto 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 +902,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%zu)", + name, data.initial, '.', pend - p); } } } @@ -947,8 +961,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,22 +979,20 @@ 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); } @@ -989,7 +1000,7 @@ 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)); + nsubscript(), (fmt_size_t)dimensions(field)); char *output = xasprintf("%s %s %s", field? field_str(field) : "(none)", 0 < dimensions(field)? subscripts : "", @@ -1005,18 +1016,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 +1104,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 +1117,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 +1377,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 +1386,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 +1416,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 +1444,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 +1506,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 +1535,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 +1582,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; } @@ -1741,11 +1743,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 +1765,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 +1802,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 +1839,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 +1855,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() ) { @@ -1831,25 +1870,42 @@ bool cobol_filename( const char *name, ino_t inode ) { } 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,18 +1913,17 @@ 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(); - 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; +location_t location_from_lineno() { return token_location; } + template <typename LOC> static void gcc_location_set_impl( const LOC& loc ) { @@ -1896,11 +1951,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); @@ -1919,6 +1972,8 @@ verify_format( const char gmsgid[] ) { static const diagnostic_option_id option_zero; size_t parse_error_inc(); +void ydferror( const char gmsgid[], ... ) ATTRIBUTE_GCOBOL_DIAG(1, 2); + void ydferror( const char gmsgid[], ... ) { verify_format(gmsgid); @@ -1941,7 +1996,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,10 +2004,10 @@ 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) { + explicit temp_loc_t( const YDFLTYPE& loc) : orig(token_location) { YYLTYPE lloc = { loc.first_line, loc.first_column, loc.last_line, loc.last_column }; @@ -1995,21 +2050,14 @@ 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; - - 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 yyerror( const char gmsgid[], ... ) { temp_loc_t looker; verify_format(gmsgid); @@ -2062,7 +2110,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 +2123,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 +2131,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 +2143,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 +2186,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 +2228,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; } @@ -2304,7 +2353,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 +2364,7 @@ bool fisdigit(int c) bool fisspace(int c) { return ISSPACE(c); - }; + } int ftolower(int c) { return TOLOWER(c); @@ -2327,7 +2376,7 @@ int ftoupper(int c) bool fisprint(int c) { return ISPRINT(c); - }; + } // 8.9 Reserved words static const std::set<std::string> reserved_words = { diff --git a/gcc/cobol/util.h b/gcc/cobol/util.h index 20d735d..165915a 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; +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,19 @@ 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(); + +unsigned long gb4( size_t input ); + +template <typename P> +static inline const void * +as_voidp( P p ) { + return static_cast<const void *>(p); +} #endif |