diff options
Diffstat (limited to 'gcc/cobol')
45 files changed, 8906 insertions, 6869 deletions
diff --git a/gcc/cobol/ChangeLog b/gcc/cobol/ChangeLog index e386591..4b05399 100644 --- a/gcc/cobol/ChangeLog +++ b/gcc/cobol/ChangeLog @@ -1,3 +1,1182 @@ +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 + * Make-lang.in: Change how $(FLEX) is invoked. + * cdf.y: Change parser tokens. + * gcobc: Changed how name is inferred for PR119337 + * gcobol.1: Documentation for SOURCE format heuristic + * genapi.cc: Eliminate __gg__odo_violation. + (parser_display_field): Change comment. + * genutil.cc:Eliminate __gg__odo_violation. + (REFER): New macro for analyzing subscript/refmod calculations. + (get_integer_value): Likewise. + (get_data_offset): Eliminate __gg__odo_violation. + (scale_by_power_of_ten_N): Eliminate unnecessary var_decl_rdigits operation. + (refer_is_clean): Check for FldLiteralN. + (REFER_CHECK): Eliminate. + (refer_refmod_length): Streamline var_decl_rdigits processing. + (refer_fill_depends): Likewise. + (refer_offset): Streamline processing when FldLiteralN. + (refer_size): Tag with REFER macro. + (refer_size_dest): Likewise. + (refer_size_source): Likewise. + * genutil.h (get_integer_value): Delete declaration for odo_violation; + change comment for get_integer_value + (REFER_CHECK): Delete declaration. + (refer_check): Delete #define. + * lexio.cc (is_fixed_format): Changes for source format auto-detect. + (is_reference_format): Likewise. + (check_source_format_directive): Likewise. + (valid_sequence_area): Likewise. + (is_p): Likewise. + (is_program_id): Likewise. + (likely_nist_file): Likewise. + (infer_reference_format): Likewise. + (cdftext::free_form_reference_format): Likewise. + * parse.y: Token changes. + * parse_ante.h (class tokenset_t): Likewise. + (class current_tokens_t): Likewise. + (cmd_or_env_special_of): Likewise. + * scan.l: Likewise. + * scan_ante.h (bcomputable): Likewise. + (keyword_alias_add): Likewise. + (struct bint_t): Likewise. + (binary_integer_usage): Likewise. + (binary_integer_usage_of): Likewise. + * scan_post.h (start_condition_str): Likewise. + * symbols.cc (symbol_table_init): Formatting. + * symbols.h (struct cbl_field_data_t): Add "input" method to field_data_t. + (keyword_alias_add): Add forward declaration. + (binary_integer_usage_of): Likewise. + * token_names.h: Change list of tokens. + * util.cc (iso_cobol_word): Change list of COBOL reserved words. + +2025-05-08 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + PR cobol/119217 + * symbols.h (NAME_MAX): Define fallback. + +2025-05-08 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + PR cobol/119217 + * dts.h (csub_match): Initialize rm_so, rm_eo fields explicitly. + +2025-05-08 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + PR cobol/119217 + * cdf-copy.cc (GLOB_BRACE): Define fallback. + (GLOB_TILDE): Likewise. + +2025-05-05 Robert Dubner <rdubner@symas.com> + + * cdf.y: Exceptions. + * except.cc (cbl_enabled_exception_t::dump): Likewise. + (cbl_enabled_exceptions_t::dump): Likewise. + (cbl_enabled_exceptions_t::status): Likewise. + (cbl_enabled_exceptions_t::encode): Likewise. + (cbl_enabled_exceptions_t::turn_on_off): Likewise. + (cbl_enabled_exceptions_t::match): Likewise. + (declarative_runtime_match): Likewise. Likewise. + * exceptg.h (struct cbl_exception_files_t): Likewise. + (class exception_turn_t): Likewise. + (apply_cdf_turn): Likewise. + * genapi.cc (treeplet_fill_source): Use refer_offset(). + (function_handle_from_name): Likewise. + (parser_initialize_programs): Likewise. + (parser_statement_begin): Likewise. + (array_of_long_long): Exceptions. + (parser_compile_ecs): Exceptions. + (parser_compile_dcls): Exceptions. + (store_location_stuff): Exceptions. + (initialize_variable_internal): Use refer_offset(). + (compare_binary_binary): Use refer_offset(). + (cobol_compare): Use refer_offset(). + (paragraph_label): Formatting. + (parser_goto): Use refer_offset(). + (parser_perform_times): Likewise. + (internal_perform_through_times): Likewise. + (parser_enter_file): Exceptions. + (psa_FldLiteralN): Add comment. + (parser_accept): Use refer_offset(). + (parser_accept_command_line): Likewise. + (parser_accept_command_line_count): Likewise. + (parser_accept_envar): Likewise. + (parser_set_envar): Likewise. + (parser_display_internal): Likewise. + (parser_initialize_table): Likewise. + (parser_sleep): Likewise. + (parser_allocate): Likewise. + (parser_free): Likewise. + (parser_division): Likewise. + (parser_relop_long): Likewise. + (parser_see_stop_run): Likewise. + (parser_classify): Likewise. + (parser_file_add): Include symbol_table_index in __gg__file_init(). + (parser_file_open): Use refer_offset(). + (parser_file_write): Move forward declaration of store_location_stuff(). + (parser_file_start): Use refer_offset(). + (parser_inspect_conv): Likewise: + (parser_intrinsic_numval_c): Likewise: + (parser_intrinsic_subst): Likewise: + (parser_intrinsic_call_1): Likewise: + (parser_intrinsic_call_2): Likewise: + (parser_intrinsic_call_3): Likewise: + (parser_intrinsic_call_4): Likewise: + (parser_sort): Likewise: + (parser_return_start): Exceptions. + (parser_unstring): Use refer_offset(). + (create_and_call): Likewise. + (parser_set_pointers): Use refer_offset(). + (parser_program_hierarchy): Comment. + (parser_set_handled): Exceptions; removed. + (parser_set_file_number): Exceptions; removed. + (stash_exceptions): Exceptions; removed. + (parser_exception_prepare): Exceptions; removed. + (parser_match_exception): Exceptions; eliminate blob. + (parser_check_fatal_exception): Exceptions. + (parser_push_exception): Create. + (parser_pop_exception): Create. + (mh_identical): Use refer_offset(). + (mh_source_is_literalN): Likewise. + (mh_dest_is_float): Likewise. + (mh_numeric_display): Likewise. + (mh_little_endian): Likewise. + (mh_source_is_group): Likewise. + (move_helper): Likewise. + (binary_initial_from_float128): Formatting; change error message. + (initial_from_float128): Change name to "initial_from_initial" + (initial_from_initial): Add one byte to allocation for figconsts. + (parser_symbol_add): Use initial_from_initial(). + (parser_symbol_add): Eliminate unneeded logic around actually_create... + * genapi.h: Exceptions. + * genmath.cc (fast_add): Use refer_offset(). + (fast_subtract): Likewise. + (fast_multiply): Likewise. + (fast_divide): Likewise. + * genutil.cc: Exceptions; various global definitions. + (get_integer_value): Comment. + (get_data_offset_dest): Eliminate. + (get_data_offset_source): Rename to get_data_offset(). + (get_data_offset): Use refer_offset(). + (get_binary_value): Likewise; eliminate use of literal_decl_node. + (build_array_of_treeplets): Likewise. + (build_array_of_fourplets): Likewise. + (REFER_CHECK): Comment: + (refer_refmod_length): Use get_any_capacity(); use refer_offset; + set reflen to integer_one_node. + (refer_offset_dest): Change name to refer_offset. + (refer_offset): Use get_data_offset(). + (refer_size_dest): Change name to refer_size(). + (refer_size): Use get_any_capacity(). + (refer_offset_source): Use refer_offset(). + (refer_size_source): Likewise. + (qualified_data_source): Likewise. + (qualified_data_dest): Likewise. + (qualified_data_location): Likewise. + * genutil.h: Exceptions; changes to global declarations. + * lexio.cc (likely_nist_file): Added to detect NIST file format. + (cdftext::free_form_reference_format): Handle NIST file format. + * parse.y: (strip_trailing_zeroes): Added. + Changes for exceptions. + * parse_ante.h (parse_error_inc): Likewise. + (YYLLOC_DEFAULT): Likewise. + (static_cast): Likewise. + (is_cobol_word): Change to is_cobol_charset. + (is_cobol_charset): Refine allowed characters. + (require_numeric): Change to require integer. + (require_integer): Likewise. + (current_enabled_ecs): Exceptions. + (is_integer_literal): Change interpretation. + (procedure_division_ready): Exceptions. + (statement_epilog): Likewise. + (statement_begin): Likewise. + * show_parse.h: Changes to GCOBOL_SHOW handling. + * structs.cc: Add symbol_index to cblc_file_t structure. + * symbols.cc (field_str): Repair .initial handling in FldLiteralN. + * symbols.h (struct cbl_field_t): Eliminate literal_decl_node. + (current_enabled_ecs): Exceptions. + * util.cc (cbl_message): Add final newline to error message. + (ftoupper): Added. + (iso_cobol_word): Add list of ISO reserved words. + * util.h (ftoupper): Added. + +2025-05-02 Jakub Jelinek <jakub@redhat.com> + + PR cobol/119364 + * structs.h (cbl_enabled_exception_type_node): New variable + declaration. + * structs.cc (cbl_enabled_exception_type_node): New variable. + (create_cbl_enabled_exception_t): New function. + (create_our_type_nodes): Initialize cbl_enabled_exception_type_node + using it. + * genapi.cc (stash_exceptions): Don't compare padding bits to + determine if the exceptions are the same as last time. Use + cbl_enabled_exception_type_node for target size and field offsets + and native_encode_expr to write each field into byte sequence. + +2025-05-02 Jakub Jelinek <jakub@redhat.com> + + PR cobol/119364 + * util.cc (is_numeric_edited): Use HOST_SIZE_T_PRINT_UNSIGNED + instead of "%zu" and cast corresponding argument to fmt_size_t. + (normalize_picture): Use GCC_PRISZ instead of "z" and pass address + of fmt_size_t var to sscanf and copy afterwards. + (cbl_refer_t::str): Use HOST_SIZE_T_PRINT_UNSIGNED instead of + "%zu" or GCC_PRISZ instead of "z" and cast corresponding argument + to fmt_size_t. + (struct move_corresponding_field): Likewise. + (valid_move): Likewise. + (ambiguous_reference): Likewise. + (parent_names): Likewise. + (find_corresponding::find_corresponding): Likewise. + (corresponding_fields): Likewise. + (unique_stack::push): Likewise. + (cobol_filename): Likewise. + * lexio.cc: Include config.h first. + (recognize_replacements): Use HOST_SIZE_T_PRINT_UNSIGNED instead of + "%zu" or GCC_PRISZ instead of "z" and cast corresponding argument + to fmt_size_t. + (check_source_format_directive): Likewise. + (parse_replacing_pair): Use size_t(0) instead of 0UL in span_t + construction. + (parse_replace_pairs): Use HOST_SIZE_T_PRINT_UNSIGNED instead of + "%zu" or GCC_PRISZ instead of "z" or HOST_SIZE_T_PRINT_DEC instead + of "%zd" and cast corresponding argument to fmt_size_t. + (parse_copy_directive): Likewise. + (parse_replace_last_off): Likewise. + (parse_replace_text): Likewise. + (bytespan_t::append): Likewise. + (cdftext::map_file): Likewise. + (cdftext::process_file): Likewise. + * symfind.cc (dump_symbol_map2): Likewise. + (dump_symbol_map_value): Likewise. + (build_symbol_map): Likewise. + (is_name::dump_key): Likewise. + (symbol_match2): Likewise. + (symbol_find): Likewise. + (symbol_find_of): Likewise. + * cdf.y: Likewise. + * symbols.cc: Include config.h first. + (cbl_field_t::set_attr): Return uint64_t rather than size_t + and replace size_t(attr) with uint64_t(attr). + (cbl_field_t::clear_attr): Likewise. + (symbol_field_capacity): Use HOST_SIZE_T_PRINT_UNSIGNED instead of + "%zu" or GCC_PRISZ instead of "z" or HOST_SIZE_T_PRINT_DEC instead + of "%zd" and cast corresponding argument to fmt_size_t. + (symbol_find_odo_debug): Likewise. + (symbols_dump): Likewise. + (calculate_capacity): Likewise. + (field_str): Likewise. + (symbols_update): Likewise. + (symbol_field_forward): Likewise. + (numeric_group_attrs): Return uint64_t rather than size_t and + change inherit variable to from size_t to uint64_t. + (new_literal_add): Use HOST_SIZE_T_PRINT_UNSIGNED instead of + "%zu" or GCC_PRISZ instead of "z" or HOST_SIZE_T_PRINT_DEC instead + of "%zd" and cast corresponding argument to fmt_size_t. + (temporaries_t::dump): Likewise. + (cbl_label_t::str): Likewise. + (symbol_label_add): Likewise. + (symbol_program_add): Likewise. + (symbol_forward_names): Likewise. + (symbol_forward_to): Likewise. + (cbl_file_key_t::deforward): Likewise. + (cbl_file_key_t::str): Likewise. + * gengen.cc (show_type): Use PRId64 instead of "ld". + (gg_unique_in_function): Use HOST_SIZE_T_PRINT_DEC instead of + %ld and cast corresponding argument to fmt_size_t. + * scan.l: Add %top section with #include "config.h". + * genmath.cc (parser_add): Use HOST_SIZE_T_PRINT_DEC instead of + %ld and cast corresponding argument to fmt_size_t. + (parser_subtract): Likewise. + * parse.y: Include "config.h" before <fstream>. Use + HOST_SIZE_T_PRINT_UNSIGNED instead of "%zu" and cast corresponding + argument to fmt_size_t. Change type of sign_attrs, group_sign and + type_implies from size_t to uint64_t. + (perform_t::ec_labels_t::new_label): Use HOST_SIZE_T_PRINT_UNSIGNED + instead of "%zu" or GCC_PRISZ instead of "z" or HOST_SIZE_T_PRINT_DEC + instead of "%zd" and cast corresponding argument to fmt_size_t. + (stringify_src_t::dump): Likewise. + (lang_check_failed): Likewise. + (numstr2i): Use GCC_PRISZ instead of "z" and pass address of temporary + with fmt_size_t type to sscanf and then copy it over. + (initialize_statement): Use HOST_SIZE_T_PRINT_UNSIGNED instead of + "%zu" or GCC_PRISZ instead of "z" or HOST_SIZE_T_PRINT_DEC instead + of "%zd" and cast corresponding argument to fmt_size_t. + (dump_inspect_oper): Likewise. + (new_literal): Likewise. + (literal_subscripts_valid): Likewise. + (eval_subject_t::label): Likewise. + * genapi.cc (level_88_helper): Likewise. + (parser_call_targets_dump): Likewise. + (combined_name): Use HOST_SIZE_T_PRINT_DEC instead of "%ld" + and cast corresponding argument to fmt_size_t. + (section_label): Likewise. + (paragraph_label): Likewise. + (leave_procedure): Likewise. + (parser_perform): Likewise. + (parser_perform_times): Likewise. + (internal_perform_through): Likewise. + (internal_perform_through_times): Likewise. + (parser_enter_program): Likewise. + (parser_init_list_size): Likewise. + (parser_init_list): Likewise. + (psa_FldLiteralN): Likewise. + (psa_FldBlob): Likewise. + (parser_assign): Likewise. + (parser_free): Pass p->field->name to dbgmsg. + (parser_division): Use HOST_SIZE_T_PRINT_DEC instead of "%ld" + and cast corresponding argument to fmt_size_t. + (perform_outofline_before_until): Likewise. + (perform_outofline_after_until): Likewise. + (perform_outofline_testafter_varying): Likewise. + (perform_outofline_before_varying): Likewise. + (perform_inline_testbefore_varying): Likewise. + (parser_inspect): Change n_operations parameter type from + unsigned long to size_t. + (parser_intrinsic_callv): Use HOST_SIZE_T_PRINT_DEC instead + of "%zd" and cast corresponding argument to fmt_size_t. + (parser_bitop): Use HOST_SIZE_T_PRINT_HEX_PURE instead of + "%lx" and cast corresponding argument to fmt_size_t. + (parser_bitwise_op): Likewise. + (parser_program_hierarchy): Use HOST_SIZE_T_PRINT_DEC instead of "%ld" + and cast corresponding argument to fmt_size_t. + (parser_set_handled): Use HOST_SIZE_T_PRINT_HEX_PURE instead of + "%lx" and cast corresponding argument to fmt_size_t. + (parser_set_numeric): Use HOST_SIZE_T_PRINT_DEC instead of "%ld" + and cast corresponding argument to fmt_size_t. + (psa_new_var_decl): Use HOST_SIZE_T_PRINT_DEC instead of "%ld" + and cast corresponding argument to fmt_size_t. + (parser_symbol_add): Use HOST_SIZE_T_PRINT_DEC instead of "%zd" + or HOST_SIZE_T_PRINT_HEX_PURE instead of "%lx" and cast corresponding + argument to fmt_size_t. + * cdf-copy.cc: Include "config.h" first. + * scan_ante.h (trim_location): Use HOST_SIZE_T_PRINT_UNSIGNED instead + of "%zu" or "%d" and cast corresponding argument to fmt_size_t. + * structs.cc (create_cblc_field_t): Use ULONGLONG instead of SIZE + for "attr". + * cbldiag.h (dbgmsg): Add ATTRIBUTE_PRINTF_1. + * gcobolspec.cc (lang_specific_driver): Use HOST_SIZE_T_PRINT_DEC + instead of "%ld" and cast corresponding argument to fmt_size_t. + * parse_ante.h (literal_of): Use HOST_SIZE_T_PRINT_UNSIGNED instead of + "%zu" or GCC_PRISZ instead of "z" or HOST_SIZE_T_PRINT_DEC instead + of "%zd" and cast corresponding argument to fmt_size_t. + (evaluate_elem_t::dump): Likewise. + (arith_t::another_pair): Likewise. + (current_t::end_program): Likewise. + (file_add): Likewise. + (implicit_paragraph): Likewise. + (implicit_section): Likewise. + (data_division_ready): Use HOST_SIZE_T_PRINT_DEC instead of "%d" + and cast corresponding argument to fmt_size_t. + * symbols.h (struct cbl_field_t): Change attr member type from size_t + to uint64_t. + (cbl_field_t::set_attr): Change return type from size_t to uint64_t. + (cbl_field_t::clear_attr): Likewise. + (function_descr_t::init): Use HOST_SIZE_T_PRINT_UNSIGNED instead of + "%zu" or GCC_PRISZ instead of "z" or HOST_SIZE_T_PRINT_DEC instead + of "%zd" and cast corresponding argument to fmt_size_t. + (cbl_perform_tgt_t::dump): Likewise. + (numeric_group_attrs): Change return type from size_t to uint64_t. + +2025-04-24 Robert Dubner <rdubner@symas.com> + + * genapi.cc: (initialize_variable_internal): Change TRACE1 formatting. + (create_and_call): Repair RETURN-CODE processing. + (mh_source_is_group): Repair run-time IF type comparison. + (psa_FldLiteralA): Change TRACE1 formatting. + (parser_symbol_add): Eliminate unnecessary code. + * genutil.cc: Eliminate SET_EXCEPTION_CODE macro. + (get_data_offset_dest): Repair set_exception_code logic. + (get_data_offset_source): Likewise. + (get_binary_value): Likewise. + (refer_refmod_length): Likewise. + (refer_fill_depends): Likewise. + (refer_offset_dest): Likewise. + (refer_size_dest): Likewise. + (refer_offset_source): Likewise. + +2025-04-16 Bob Dubner <rdubner@symas.com> + + PR cobol/119759 + * LICENSE: Deleted. + +2025-04-15 Richard Biener <rguenther@suse.de> + + PR cobol/119302 + * Make-lang.in (GCOBOLIO_INSTALL_NAME): Define. + Use $(GCOBOLIO_INSTALL_NAME) for gcobol.3 manpage source + upon install. + +2025-04-14 Jakub Jelinek <jakub@redhat.com> + + PR cobol/119776 + * lang.opt (fmax-errors): Remove. + * lang.opt.urls: Regenerate. + * cobol1.cc (cobol_langhook_handle_option) <case OPT_fmax_errors>: + Remove. + * gcobol.1: Document -fmax-errors=nerror rather than + -fmax-errors nerror. + +2025-04-14 Jakub Jelinek <jakub@redhat.com> + + PR cobol/119777 + * lang.opt (include): Remove Var(cobol_include). + * cobol1.cc (cobol_langhook_handle_option) <case OPT_include>: Use + arg instead of cobol_include. + +2025-04-14 Jakub Jelinek <jakub@redhat.com> + + PR cobol/119777 + * lang.opt (fsyntax-only): Remove. + * lang.opt.urls: Regenerate. + +2025-04-13 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + Simon Sobisch <simonsobisch@gnu.org> + + PR cobol/119217 + * parse.y: Rename OVERFLOW to OVERFLOW_kw. + Specify type name in %token directive. + * scan.l: Likewise. + * token_names.h: Regenerate. + +2025-04-13 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + PR cobol/119217 + * util.cc (class timespec_t): Rename to cbl_timespec. + +2025-04-13 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + * genapi.cc: Include target.h. + (section_label): Use ASM_COMMENT_START. + (paragraph_label): Likewise. + (parser_perform): Likewise. + (internal_perform_through): Likewise. + (hijack_for_development): Likewise. + +2025-04-12 Bob Dubner <rdubner@symas.com> + + PR cobol/119694 + * cbldiag.h: Eliminate getenv() calls. + * cdf.y: Likewise. + * cobol1.cc: Likewise. + * except.cc: Likewise. + * genapi.cc: Likewise. + * lexio.cc: Likewise. + * parse.y: Likewise. + * scan_ante.h: Likewise. + * show_parse.h: Likewise. + * symbols.cc: Likewise. + * symfind.cc: Likewise. + * util.cc: Likewise. + +2025-04-09 Bob Dubner <rdubner@symas.com> + + PR cobol/119682 + * genapi.cc: (cobol_compare): Change the call to __gg__compare(). + 2025-04-08 Jakub Jelinek <jakub@redhat.com> PR cobol/119364 diff --git a/gcc/cobol/LICENSE b/gcc/cobol/LICENSE deleted file mode 100644 index aa5ba60..0000000 --- a/gcc/cobol/LICENSE +++ /dev/null @@ -1,29 +0,0 @@ -######################################################################### -# -# Copyright (c) 2021-2025 Symas Corporation -# -# Redistribution and use in source and binary forms, with or without -# modification, are permitted provided that the following conditions are -# met: -# -# * 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 -# copyright notice, this list of conditions and the following disclaimer -# in the documentation and/or other materials provided with the -# distribution. -# * Neither the name of the Symas Corporation nor the names of its -# contributors may be used to endorse or promote products derived from -# this software without specific prior written permission. -# -# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -# OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/gcc/cobol/Make-lang.in b/gcc/cobol/Make-lang.in index 422ebe2..e884212 100644 --- a/gcc/cobol/Make-lang.in +++ b/gcc/cobol/Make-lang.in @@ -34,7 +34,11 @@ # - 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)') GCOBC_INSTALL_NAME := $(shell echo gcobc|sed '$(program_transform_name)') @@ -156,10 +160,9 @@ cobol/cdf.cc: cobol/cdf.y FLEX_WARNING = warning, dangerous trailing context cobol/scan.cc: cobol/scan.l - $(FLEX) -o$@ $(LFLAGS) $< >$@~ 2>&1 + $(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 $@~ @@ -284,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 @@ -293,7 +296,7 @@ cobol.install-common: installdirs cobol.install-man: installdirs $(INSTALL_DATA) $(srcdir)/cobol/gcobol.1 $(DESTDIR)$(man1dir)/$(GCOBOL_INSTALL_NAME)$(man1ext) - $(INSTALL_DATA) $(srcdir)/cobol/gcobol.3 $(DESTDIR)$(man3dir)/ + $(INSTALL_DATA) $(srcdir)/cobol/gcobol.3 $(DESTDIR)$(man3dir)/$(GCOBOLIO_INSTALL_NAME)$(man3ext) cobol.install-info: @@ -342,18 +345,24 @@ cobol.uninstall: rm -rf $(DESTDIR)$(bindir)/$(GCOBOL_INSTALL_NAME)$(exeext) \ $(DESTDIR)$(bindir)/$(GCOBC_INSTALL_NAME) \ $(DESTDIR)$(datadir)/gcobol/ \ - $(DESTDIR)$(man1dir)/$(GCOBOL_INSTALL_NAME).1 \ - $(DESTDIR)$(man3dir)/gcobol.3 + $(DESTDIR)$(man1dir)/$(GCOBOL_INSTALL_NAME)$(man1ext) \ + $(DESTDIR)$(man3dir)/$(GCOBOLIO_INSTALL_NAME)$(man3ext) cobol.man: 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 ed754f1..548b0f2 100644 --- a/gcc/cobol/cbldiag.h +++ b/gcc/cobol/cbldiag.h @@ -33,14 +33,20 @@ #else #define _CBLDIAG_H +#if 0 +#define gcobol_getenv(x) getenv(x) +#else +#define gcobol_getenv(x) ((char *)nullptr) +#endif + 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 @@ -73,25 +79,28 @@ 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[], ... ); +void dbgmsg( const char fmt[], ... ) ATTRIBUTE_PRINTF_1; void gcc_location_set( const YYLTYPE& loc ); @@ -100,8 +109,8 @@ 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; - if( yy_flex_debug && getenv("update_location") ) + 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, loc.first_line, loc.first_column, loc.last_line, loc.last_column); diff --git a/gcc/cobol/cdf-copy.cc b/gcc/cobol/cdf-copy.cc index c620c82..11be9b8 100644 --- a/gcc/cobol/cdf-copy.cc +++ b/gcc/cobol/cdf-copy.cc @@ -34,7 +34,7 @@ // // We regret any confusion engendered. -#include <glob.h> +#include "config.h" #include "cobol-system.h" #include "cbldiag.h" @@ -75,7 +75,6 @@ * space. This function only applies them. */ -extern int yydebug; const char * cobol_filename(); bool is_fixed_format(); bool is_reference_format(); @@ -125,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'; @@ -179,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; @@ -231,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 @@ -265,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); @@ -300,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; @@ -313,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 6392f89..3344271 100644 --- a/gcc/cobol/cdf.y +++ b/gcc/cobol/cdf.y @@ -155,78 +155,17 @@ void input_file_status_notify(); static char *display_msg; const char * keyword_str( int token ); -static class exception_turns_t { - typedef std::list<size_t> filelist_t; - typedef std::map<ec_type_t, filelist_t> ec_filemap_t; - ec_filemap_t exceptions; - public: - bool enabled, location; - - exception_turns_t() : enabled(false), location(false) {}; - - const ec_filemap_t& exception_files() const { return exceptions; } - - struct args_t { - size_t nexception; - cbl_exception_files_t *exceptions; - }; - - 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)); - } - auto elem = exceptions.find(type); - if( elem != exceptions.end() ) return false; // cannot add twice - - exceptions[type] = files; - return true; - } - - args_t args() const { - args_t args; - args.nexception = exceptions.size(); - args.exceptions = NULL; - if( args.nexception ) { - args.exceptions = new cbl_exception_files_t[args.nexception]; - } - std::transform( exceptions.begin(), exceptions.end(), args.exceptions, - []( auto& input ) { - cbl_exception_files_t output; - output.type = input.first; - output.nfile = input.second.size(); - output.files = NULL; - if( output.nfile ) { - output.files = new size_t[output.nfile]; - std::copy(input.second.begin(), - input.second.end(), - output.files ); - } - return output; - } ); - return args; - } - - void clear() { - for( auto& ex : exceptions ) { - ex.second.clear(); - } - exceptions.clear(); - enabled = location = false; - } - -} exception_turns; - - -static bool -apply_cdf_turn( exception_turns_t& turns ) { - for( auto elem : turns.exception_files() ) { +exception_turn_t exception_turn; + +bool +apply_cdf_turn( const exception_turn_t& turn ) { + for( auto elem : turn.exception_files() ) { std::set<size_t> files(elem.second.begin(), elem.second.end()); - enabled_exceptions.turn_on_off(turns.enabled, - turns.location, + enabled_exceptions.turn_on_off(turn.enabled, + turn.location, elem.first, files); } - if( getenv("SHOW_PARSE") ) enabled_exceptions.dump(); + if( getenv("GCOBOL_SHOW") ) enabled_exceptions.dump(); return true; } %} @@ -241,70 +180,72 @@ apply_cdf_turn( exception_turns_t& turns ) { std::set<size_t> *files; } +%printer { fprintf(yyo, "'%s'", $$? "true" : "false" ); } <boolean> %printer { fprintf(yyo, "'%s'", $$ ); } <string> %printer { fprintf(yyo, "%s '%s'", keyword_str($$.token), $$.string? $$.string : "<nil>" ); } <cdfarg> -%printer { fprintf(yyo, "%ld '%s'", - $$.number, $$.string? $$.string : "" ); } <cdfval> +/* cppcheck-suppress invalidPrintfArgType_sint */ +%printer { fprintf(yyo, HOST_SIZE_T_PRINT_DEC " '%s'", + (fmt_size_t)$$.number, $$.string? $$.string : "" ); } <cdfval> %type <string> NAME NUMSTR LITERAL PSEUDOTEXT %type <string> LSUB RSUB SUBSCRIPT %type <cdfarg> namelit name_any name_one %type <string> name subscript subscripts inof %token <boolean> BOOL -%token <number> FEATURE 363 NUMBER 302 EXCEPTION_NAME 280 "EXCEPTION NAME" +%token <number> FEATURE 365 NUMBER 303 EXCEPTION_NAME 280 "EXCEPTION NAME" %type <cdfval> cdf_expr %type <cdfval> cdf_relexpr cdf_reloper cdf_and cdf_bool_expr %type <cdfval> cdf_factor -%type <boolean> cdf_cond_expr override +%type <boolean> cdf_cond_expr override except_check %type <file> filename %type <files> filenames -%token BY 476 -%token COPY 360 -%token CDF_DISPLAY 382 ">>DISPLAY" -%token IN 595 +%token BY 478 +%token COPY 362 +%token CDF_DISPLAY 384 ">>DISPLAY" +%token IN 597 %token NAME 286 -%token NUMSTR 304 "numeric literal" -%token OF 676 -%token PSEUDOTEXT 711 -%token REPLACING 733 -%token LITERAL 297 -%token SUPPRESS 374 - -%token LSUB 365 "(" -%token SUBSCRIPT 373 RSUB 370 ")" - -%token CDF_DEFINE 381 ">>DEFINE" -%token CDF_IF 383 ">>IF" -%token CDF_ELSE 384 ">>ELSE" -%token CDF_END_IF 385 ">>END-IF" -%token CDF_EVALUATE 386 ">>EVALUATE" -%token CDF_WHEN 387 ">>WHEN" -%token CDF_END_EVALUATE 388 ">>END-EVALUATE" - -%token AS 458 CONSTANT 359 DEFINED 361 +%token NUMSTR 305 "numeric literal" +%token OF 678 +%token PSEUDOTEXT 713 +%token REPLACING 735 +%token LITERAL 298 +%token SUPPRESS 376 + +%token LSUB 367 "(" +%token SUBSCRIPT 375 RSUB 372 ")" + +%token CDF_DEFINE 383 ">>DEFINE" +%token CDF_IF 385 ">>IF" +%token CDF_ELSE 386 ">>ELSE" +%token CDF_END_IF 387 ">>END-IF" +%token CDF_EVALUATE 388 ">>EVALUATE" +%token CDF_WHEN 389 ">>WHEN" +%token CDF_END_EVALUATE 390 ">>END-EVALUATE" + +%token AS 460 CONSTANT 361 DEFINED 363 %type <boolean> DEFINED -%token OTHER 688 PARAMETER_kw 366 "PARAMETER" -%token OFF 677 OVERRIDE 367 -%token THRU 929 -%token TRUE_kw 803 "True" +%token OTHER 690 PARAMETER_kw 368 "PARAMETER" +%token OFF 679 OVERRIDE 369 +%token THRU 931 +%token TRUE_kw 805 "True" -%token CALL_COBOL 389 "CALL" -%token CALL_VERBATIM 390 "CALL (as C)" +%token CALL_COBOL 391 "CALL" +%token CALL_VERBATIM 392 "CALL (as C)" -%token TURN 805 CHECKING 486 LOCATION 639 ON 679 WITH 831 +%token TURN 807 CHECKING 488 LOCATION 641 ON 681 WITH 833 -%left OR 930 -%left AND 931 -%right NOT 932 -%left '<' '>' '=' NE 933 LE 934 GE 935 +%left OR 932 +%left AND 933 +%right NOT 934 +%left '<' '>' '=' NE 935 LE 936 GE 937 %left '-' '+' %left '*' '/' -%right NEG 937 +%right NEG 939 %define api.prefix {ydf} %define api.token.prefix{YDF_} @@ -322,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; } ; @@ -424,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"); } } ; @@ -443,8 +386,8 @@ override: %empty { $$ = false; } cdf_turn: TURN except_names except_check { - apply_cdf_turn(exception_turns); - exception_turns.clear(); + apply_cdf_turn(exception_turn); + exception_turn.clear(); } ; @@ -463,22 +406,20 @@ except_names: except_name ; except_name: EXCEPTION_NAME[ec] { assert($ec != ec_none_e); - exception_turns.add_exception(ec_type_t($ec)); + exception_turn.add_exception(ec_type_t($ec)); } | EXCEPTION_NAME[ec] filenames { assert($ec != ec_none_e); - std::list<size_t> files; - std::copy( $filenames->begin(), $filenames->end(), - std::back_inserter(files) ); - exception_turns.add_exception(ec_type_t($ec), files); + std::list<size_t> files($filenames->begin(), $filenames->end()); + exception_turn.add_exception(ec_type_t($ec), files); } ; -except_check: CHECKING on { exception_turns.enabled = true; } - | CHECKING OFF { exception_turns.enabled = false; } +except_check: CHECKING on { $$ = exception_turn.enable(true); } + | CHECKING OFF { $$ = exception_turn.enable(false); } | CHECKING on with LOCATION { - exception_turns.enabled = exception_turns.location = true; + $$ = exception_turn.enable(true, true); } ; @@ -491,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); } } ; @@ -510,7 +451,6 @@ cdf_if: CDF_IF cdf_cond_expr { scanner_parsing(YDF_CDF_IF, $2); } | CDF_IF error { - ////if( scanner_parsing() ) yyerrok; } CDF_END_IF { // not pushed, don't pop if( ! scanner_parsing() ) YYACCEPT; } @@ -529,18 +469,17 @@ cdf_eval_obj: cdf_cond_expr ; cdf_cond_expr: BOOL - | NAME DEFINED[maybe] + | NAME DEFINED { auto p = dictionary.find($1); bool found = p != dictionary.end(); - if( !$maybe ) found = ! found; - if( ! found ) { - $$ = !$2; - dbgmsg("CDF: %s not found in dictionary (result %s)", + if( !$DEFINED ) found = ! found; + $$ = found; + if( found ) { + dbgmsg("CDF: %s found in dictionary (result %s)", $1, $$? "true" : "false"); } else { - $$ = $2; - dbgmsg("CDF: %s found in dictionary (result %s)", + dbgmsg("CDF: %s not found in dictionary (result %s)", $1, $$? "true" : "false"); } } @@ -580,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 @@ -594,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); } @@ -630,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; } @@ -648,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] @@ -656,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; } } ; @@ -828,7 +767,8 @@ defined_cmd( const char arg[] ) if( yydebug ) { if( cdf_name->second.is_numeric() ) { - dbgmsg("%s: added -D %s = %ld", __func__, name, cdf_name->second.as_number()); + dbgmsg("%s: added -D %s = " HOST_SIZE_T_PRINT_DEC, + __func__, name, (fmt_size_t)cdf_name->second.as_number()); } else { dbgmsg("%s: added -D %s = \"%s\"", __func__, name, cdf_name->second.string); } @@ -927,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; @@ -957,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 1e690ff..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 @@ -294,7 +293,7 @@ cobol_langhook_init_options_struct (struct gcc_options *opts) { cobol_set_debugging( false, false, false ); - copybook_directory_add( getenv("GCOB_COPYBOOK") ); + copybook_directory_add( getenv("GCOBOL_COPYBOOK") ); } static unsigned int @@ -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; @@ -385,10 +388,6 @@ cobol_langhook_handle_option (size_t scode, return true; } - case OPT_fmax_errors: - flag_max_errors = atoi(arg); - return true; - case OPT_ffixed_form: cobol_set_indicator_column(-7); return true; @@ -413,8 +412,8 @@ cobol_langhook_handle_option (size_t scode, } return true; case OPT_include: - if( ! include_file_add(cobol_include) ) { - cbl_errx( "could not include %s", cobol_include); + if( ! include_file_add(arg) ) { + cbl_errx( "could not include %s", arg); } return true; @@ -572,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 c345dc7..aa3fa58 100644 --- a/gcc/cobol/dts.h +++ b/gcc/cobol/dts.h @@ -33,14 +33,15 @@ namespace dts { : input(input) , first(NULL), second(NULL), matched(false) { - static regmatch_t empty = { -1, -1 }; - regmatch_t& self(*this); + static regmatch_t empty; + empty.rm_so = empty.rm_eo = -1; + 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; @@ -67,7 +68,6 @@ namespace dts { #if __cpp_exceptions throw std::logic_error(msg); #else - pattern = NULL; cbl_errx("%s", msg); #endif } @@ -77,7 +77,7 @@ namespace dts { size_t size() const { return nsubexpr; } bool ready() const { return pattern != NULL; } private: - regex( const regex& ) {} + regex( const regex& ) = default; }; inline bool regex_search( const char input[], const char *eoinput, @@ -87,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 1485a33..60b8416 100644 --- a/gcc/cobol/except.cc +++ b/gcc/cobol/except.cc @@ -43,6 +43,7 @@ #include "gengen.h" #include "../../libgcobol/exceptl.h" #include "util.h" +#include "genutil.h" #pragma GCC diagnostic ignored "-Wmissing-field-initializers" @@ -50,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; } @@ -74,103 +75,141 @@ ec_level( ec_type_t ec ) { return 3; } +void +cbl_enabled_exception_t::dump( int i ) const { + cbl_message(2, "cbl_enabled_exception_t: %2d {%s, %s, %zu}", + i, + location? "location" : " none", + ec_type_str(ec), + file ); +} + cbl_enabled_exceptions_t enabled_exceptions; void cbl_enabled_exceptions_t::dump() const { + extern int yydebug; + int debug = 1; + std::swap(debug, yydebug); // dbgmsg needs yydebug + if( empty() ) { - cbl_message(2, "cbl_enabled_exceptions_t: no exceptions" ); + dbgmsg("cbl_enabled_exceptions_t: no exceptions" ); + std::swap(debug, yydebug); return; } int i = 1; for( auto& elem : *this ) { - cbl_message(2, "cbl_enabled_exceptions_t: %2d {%s, %s, %s, %zu}", + dbgmsg("cbl_enabled_exceptions_t: %2d {%s, %s, %lu}", i++, - elem.enabled? " enabled" : "disabled", - elem.location? "location" : " none", + 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 { + std::vector<uint64_t> encoded; + auto p = std::back_inserter(encoded); + for( const auto& ec : *this ) { + *p++ = ec.location; + *p++ = ec.ec; + *p++ = ec.file; + } + return encoded; +} -bool +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 ) { - // A Level 3 EC is added unilaterally; it can't knock out a lower level. + // Update current enabled ECs tree on leaving this function. + class update_parser_t { + const cbl_enabled_exceptions_t& ecs; + public: + 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); + } + } update_parser(*this); + + // A Level 3 EC is added unilaterally; it can't affect a higher level. if( ec_level(type) == 3 ) { if( files.empty() ) { - auto elem = cbl_enabled_exception_t(enabled, location, type); - apply(elem); - return true; + auto elem = cbl_enabled_exception_t(location, type); + apply(enabled, elem); + return; } for( size_t file : files ) { - auto elem = cbl_enabled_exception_t(enabled, location, type, file); - apply(elem); + auto elem = cbl_enabled_exception_t(location, type, file); + apply(enabled, elem); } - return true; + return; } - // std::set::erase_if became available only in C++20. - if( enabled ) { // remove any disabled + // A new Level 1 or Level 2 EC is likewise simply added. + if( enabled ) { if( files.empty() ) { - auto p = begin(); - while( p != end() ) { - if( !p->enabled && ec_cmp(type, p->ec) ) { - p = erase(p); - } else { - ++p; - } - } - } else { - for( size_t file: files ) { - auto p = begin(); - while( p != end() ) { - if( !p->enabled && file == p->file && ec_cmp(type, p->ec) ) { - p = erase(p); - } else { - ++p; - } - } - } + auto elem = cbl_enabled_exception_t(location, type); + apply(enabled, elem); + return; + } + for( size_t file: files ) { + auto elem = cbl_enabled_exception_t(location, type, file); + apply(enabled, elem); } - auto elem = cbl_enabled_exception_t(enabled, location, type); - apply(elem); - return true; + return; } + assert(!enabled); assert(ec_level(type) < 3); + /* + * >> TURN EC [files] CHECKING OFF + */ + if( files.empty() ) { + // A Level 1 EC with no files disables all ECs if( type == ec_all_e ) { clear(); - return true; + return; } - // Remove any matching Level-2 or Level-3 ECs, regardless of their files. + // Because TURN CHECKING OFF mentioned no files, Remove any matching + // Level-2 or Level-3 ECs, regardless of their files. auto p = begin(); while( end() != (p = std::find_if( begin(), end(), [ec = type]( const auto& elem ) { return - elem.enabled && elem.ec != ec_all_e && ec_cmp(ec, elem.ec); } )) ) { erase(p); } - // Keep the EC as an exception if a higher-level would othewise apply. + // Keep the EC as an override if a higher-level would othewise apply. p = std::find_if( begin(), end(), [ec = type]( const auto& elem ) { return - elem.enabled && (elem.ec == ec_all_e || elem.ec < ec) && elem.file == 0 && ec_cmp(ec, elem.ec); } ); if( p != end() ) { - auto elem = cbl_enabled_exception_t(enabled, location, type); - apply(elem); + auto elem = cbl_enabled_exception_t(location, type); + apply(enabled, elem); } } else { // Remove any matching or lower-level EC for the same file. @@ -179,47 +218,34 @@ cbl_enabled_exceptions_t::turn_on_off( bool enabled, while( end() != (p = std::find_if( begin(), end(), [ec = type, file]( const auto& elem ) { return - elem.enabled && // ec is higher level and matches (ec == ec_all_e || ec <= elem.ec) && file == elem.file && ec_cmp(ec, elem.ec); } )) ) { erase(p); } - // Keep the EC as an exception if a higher-level would othewise apply. + // Keep the EC as an override if a higher-level would othewise apply. p = std::find_if( begin(), end(), [ec = type, file]( const auto& elem ) { return - elem.enabled && (elem.ec == ec_all_e || elem.ec < ec) && file == elem.file && ec_cmp(ec, elem.ec); } ); if( p != end() ) { - auto elem = cbl_enabled_exception_t(enabled, location, type, file); - apply(elem); + auto elem = cbl_enabled_exception_t(location, type, file); + apply(enabled, elem); } } } - - return true; + return; } const cbl_enabled_exception_t * -cbl_enabled_exceptions_t::match( ec_type_t type, size_t file ) { +cbl_enabled_exceptions_t::match( ec_type_t type, size_t file ) const { auto output = enabled_exception_match( begin(), end(), type, file ); 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 ) { @@ -229,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 @@ -311,48 +277,60 @@ size_t current_file_index(); file_status_t current_file_handled_status(); void -declarative_runtime_match( cbl_field_t *declaratives, cbl_label_t *lave ) { - if( getenv("SHOW_PARSE") ) +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("TRACE1") ) + 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); - - // Send blob, get declarative section index. - auto index = new_temporary(FldNumericBin5); - parser_match_exception(index, declaratives); - - 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 ); - parser_if( yes ); - auto section = cbl_label_of(symbol_at(p->section)); - parser_perform(section); - parser_label_goto(lave); - parser_else(); - parser_fi(); + 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 ) { + // Get declarative section index matching any raised EC. + parser_match_exception(index); + + // Compare returned index to each section index. + 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(dcl.section)); + parser_push_exception(); + parser_perform(section); + parser_pop_exception(); + parser_label_goto(lave); + parser_else(); + parser_fi(); + } } - - parser_label_label(lave); - - // A performed declarative may clear the raised exception with RESUME. - // If not cleared and fatal, the default handler will exit. - parser_check_fatal_exception(); + ELSE { + 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); + } + } + ENDIF } ec_type_t diff --git a/gcc/cobol/exceptg.h b/gcc/cobol/exceptg.h index 4500c0f..f90cc28 100644 --- a/gcc/cobol/exceptg.h +++ b/gcc/cobol/exceptg.h @@ -36,26 +36,67 @@ 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 ) { return ec_disposition_t( size_t(disposition) & ~0x80 ); } - // >>TURN arguments -struct cbl_exception_files_t { - ec_type_t type; - size_t nfile; - size_t *files; - bool operator<( const cbl_exception_files_t& that ) { - return type < that.type; +class exception_turn_t; +bool apply_cdf_turn( const exception_turn_t& turn ); + +class exception_turn_t { + friend bool apply_cdf_turn( const exception_turn_t& turn ); + typedef std::list<size_t> filelist_t; + typedef std::map<ec_type_t, filelist_t> ec_filemap_t; + ec_filemap_t exceptions; + bool enabled, location; + public: + + exception_turn_t() : enabled(false), location(false) {}; + + explicit exception_turn_t( ec_type_t ec, bool enabled = true ) + : enabled(enabled), location(false) + { + add_exception(ec); + } + + bool enable( bool enabled ) { + return this->enabled = enabled; + } + bool enable( bool enabled, bool location ) { + this->location = location; + return this->enabled = enabled; + } + + const ec_filemap_t& exception_files() const { return exceptions; } + + 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)); + } + auto elem = exceptions.find(type); + if( elem != exceptions.end() ) return false; // cannot add twice + + exceptions[type] = files; + return true; + } + + void clear() { + for( auto& ex : exceptions ) { + ex.second.clear(); + } + exceptions.clear(); + enabled = location = false; } -}; -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 93e1bd302..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 "$@" @@ -142,41 +154,57 @@ do if [ "$pending_arg" ] then - opts="$opts $pending_arg $opt" + case $pending_arg in + -o) output_name="$opt" # capture named output file + ;; + esac + + 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" ;; @@ -354,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" ;; @@ -392,7 +419,13 @@ do ;; # -main # -nomain - # -o + + -o) pending_arg=$opt + ;; + -o*) output_name=$opt ## non-empty means do not infer + opts="$opts $opt" + ;; + # -O0, -Ox -O | -O2 | -Os) warn "$opt" ;; @@ -402,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) opts="$opts -dialect mf" + -std=mf | -std=mf-strict) dialect=mf ;; - -t | -T | -tlines=* | -P | -P=* | -X | --Xref) - warn "$opt (no listing)" + -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)" + ;; + -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" ;; @@ -432,7 +476,24 @@ do -x) mode= ;; - *) opts="$opts $opt" # pass through + -) output_name=a.out # nonnull to prevent overriding gcc default + opts="$opts /dev/stdin" + ;; + + *) if [ -z "$output_name" ] # first non-option argument is source file name + then + 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" + fi + opts="$opts $opt" # pass through ;; esac done diff --git a/gcc/cobol/gcobol.1 b/gcc/cobol/gcobol.1 index 64c017c..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 @@ -97,8 +97,9 @@ Define a CDF name (for use with to have the value of .Ar expr . .It Fl E -Write the CDF-processed \*[lang] input to standard output in free-form -reference format. Certain non-\*[lang] markers are included in the +Write the CDF-processed \*[lang] input to standard output in +.Em "free-form reference format". +Certain non-\*[lang] markers are included in the output to indicate where copybook files were included. For line-number consistency with the input, blank lines are retained. .Pp @@ -147,13 +148,13 @@ and in that order. .It Fl ffixed-form Use strict -.Em "Reference Format" +.Em "fixed-form reference format" in reading the \*[lang] input: 72-character lines, with a 6-character sequence area, and an indicator column. Data past column 72 are ignored. .It Fl ffree-form Force the \*[lang] input to be interpreted as -.Em "free format" . +.Em "free-form reference format". Line breaks are insignificant, except that .Ql * at the start of a line acts as a comment marker. @@ -187,12 +188,21 @@ the entire program could appear on one line. .Pp By default, .Nm -auto-detects the source code format by examining the -.Em "sequence number area" -of the first line of the first file: if those characters are all -digits or blanks, the file is assumed to be in -.Em "reference format" , +auto-detects the source code format by examining the line that +contains the text "program-id". When there are characters on past column 72 +on that line, the file is assumed to be in +.Em "extended source format", with the indicator area in column 7. +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 ... @@ -224,7 +234,7 @@ had appeared. Not all exception conditions are implemented. Any that are not produce a warning message. . -.It Fl fmax-errors Ar nerror +.It Fl fmax-errors Ns Li = Ns Ar nerror .Ar nerror represents the number of error messages produced. Without this option, .Nm @@ -1000,9 +1010,12 @@ to standard error as a warning message. may be one of: .Bl -tag -compact .It Sy FIXED -Source conforms to \*[lang] Reference Format with unlimited line length. +Source conforms to \*[lang] +.Em "fixed-form reference format" +with unlimited line length. .It Sy FREE -Line endings and indentation are ignored by the compiler, except that a +Source conforms to \*[lang] +.Em "free-form reference format". .Ql "*" at the beginning of a line is recognized as a comment. .El @@ -1073,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 @@ -1152,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 @@ -1279,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 @@ -1310,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 @@ -1346,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 4df9f8d..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; @@ -541,13 +541,14 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, #endif if( verbose && new_options != original_options ) { - fprintf(stderr, _("Driving: (%ld)\n"), new_option_count); + fprintf(stderr, _("Driving: (" HOST_SIZE_T_PRINT_DEC ")\n"), + (fmt_size_t)new_option_count); for(size_t i=0; i<new_option_count; i++) { fprintf(stderr, - " [%2ld] %4ld %s\n", - i, - new_options[i].opt_index, + " [%2" GCC_PRISZ "d] %4" GCC_PRISZ "d %s\n", + (fmt_size_t)i, + (fmt_size_t)new_options[i].opt_index, new_options[i].orig_option_with_args_text); } fprintf (stderr, "\n"); diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index c91237b..8017788 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -34,6 +34,7 @@ #include "tree-iterator.h" #include "stringpool.h" #include "diagnostic-core.h" +#include "target.h" #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" @@ -59,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; @@ -75,10 +77,12 @@ static int pseudo_label = 1; static bool suppress_cobol_entry_point = false; static char ach_cobol_entry_point[256] = ""; -bool bSHOW_PARSE = getenv("SHOW_PARSE"); +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 @@ -116,14 +120,14 @@ void treeplet_fill_source(TREEPLET &treeplet, cbl_refer_t &refer) { treeplet.pfield = gg_get_address_of(refer.field->var_decl_node); - treeplet.offset = refer_offset_source(refer); + treeplet.offset = refer_offset(refer); treeplet.length = refer_size_source(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); } @@ -139,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 // @@ -198,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("TRACE1") ? getenv("TRACE1") : gv_trace_switch; + bTRACE1 = getenv("GCOBOL_TRACE") ? getenv("GCOBOL_TRACE") :gv_trace_switch; if( bTRACE1 && strcmp(bTRACE1, "0") != 0 ) { @@ -264,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 @@ -426,7 +441,8 @@ level_88_helper(size_t parent_capacity, nbuild += first_name_length; } } - returned_size = sprintf(retval, "%zdA", nbuild); + returned_size = sprintf(retval, HOST_SIZE_T_PRINT_DEC "A", + (fmt_size_t)nbuild); memcpy(retval + returned_size, builder, nbuild); returned_size += nbuild; free(first_name); @@ -567,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 @@ -690,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); } /* @@ -725,24 +753,30 @@ parser_call_target( tree func ) cbl_call_convention_t parser_call_target_convention( tree func ) { - auto p = called_targets.find(func); - if( p != called_targets.end() ) return p->second; + auto p = called_targets.find(func); + if( p != called_targets.end() ) + { + // This was found in our list of call targets + return p->second; + } - return cbl_call_cobol_e; + return cbl_call_cobol_e; } void parser_call_targets_dump() { - dbgmsg( "call targets for #%zu", current_program_index() ); + dbgmsg( "call targets for #" HOST_SIZE_T_PRINT_UNSIGNED, + (fmt_size_t)current_program_index() ); for( const auto& elem : call_targets ) { const auto& k = elem.first; const auto& v = elem.second; - fprintf(stderr, "\t#%-3zu %s calls %s ", - k.caller, cbl_label_of(symbol_at(k.caller))->name, k.called); + fprintf(stderr, "\t#%-3" GCC_PRISZ "u %s calls %s ", + (fmt_size_t)k.caller, cbl_label_of(symbol_at(k.caller))->name, + 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"); @@ -754,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(); @@ -776,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), - qualified_data_source(name), + gg_memcpy(gg_get_address_of(function_pointer), + qualified_data_location(name), sizeof_pointer); } - return function_handle; + return function_pointer; } else if( use_static_call() && is_literal(name.field) ) { - // It's a literal, and we are using static calls. Generate the CALL, and - // pass the address expression to parser_call_target(). That will cause - // parser_call_target_update() to replace any nested CALL "foo" with the - // local "foo.60" name. + tree fndecl_type = build_varargs_function_type_array( function_return_type, + 0, // No parameters yet + NULL); // And, hence, no types - // We create a reference to it, which is later resolved by the linker. - tree addr_expr = gg_get_function_address( function_return_type, - name.field->data.initial); - gg_assign(function_handle, addr_expr); - - tree func = TREE_OPERAND(addr_expr, 0); - parser_call_target(func); // add function to list of call targets + // Fetch the FUNCTION_DECL for that FUNCTION_TYPE + tree function_decl = gg_build_fn_decl(name.field->data.initial, + fndecl_type); + // Take the address of the function decl: + tree address_of_function = gg_get_address_of(function_decl); + gg_assign(function_pointer, address_of_function); } else { - // This is not a literal or static + // We are not using static calls. if( name.field->type == FldLiteralA ) { - gg_assign(function_handle, + gg_assign(function_pointer, gg_cast(build_pointer_type(function_type), - gg_call_expr(VOID_P, - "__gg__function_handle_from_literal", - build_int_cst_type(INT, current_function->our_symbol_table_index), - gg_string_literal(name.field->data.initial), - NULL_TREE))); + gg_call_expr( VOID_P, + "__gg__function_handle_from_literal", + build_int_cst_type(INT, + current_function->our_symbol_table_index), + gg_string_literal(name.field->data.initial), + NULL_TREE))); } else { - gg_assign(function_handle, + gg_assign(function_pointer, gg_cast(build_pointer_type(function_type), gg_call_expr( VOID_P, - "__gg__function_handle_from_name", - build_int_cst_type(INT, current_function->our_symbol_table_index), - gg_get_address_of(name.field->var_decl_node), - refer_offset_source(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 @@ -873,40 +915,289 @@ 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); } } -void parser_statement_begin() +static +tree +array_of_long_long(const char *name, const std::vector<uint64_t>& vals) + { + // We need to create a file-static static array of 64-bit integers: + tree array_of_ulonglong_type = build_array_type_nelts(ULONGLONG, vals.size()+1); + tree array_of_ulonglong = gg_define_variable( array_of_ulonglong_type, + name, + vs_file_static); + // We have the array. Now we need to build the constructor for it + tree constr = make_node(CONSTRUCTOR); + TREE_TYPE(constr) = array_of_ulonglong_type; + TREE_STATIC(constr) = 1; + TREE_CONSTANT(constr) = 1; + + // The first element of the array contains the number of elements to follow + CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr), + build_int_cst_type(SIZE_T, 0), + build_int_cst_type(ULONGLONG, vals.size()) ); + for(size_t i=0; i<vals.size(); i++) + { + CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr), + build_int_cst_type(SIZE_T, i+1), + build_int_cst_type(ULONGLONG, vals[i]) ); + } + DECL_INITIAL(array_of_ulonglong) = constr; + return array_of_ulonglong; + } + +/* + * As ECs are enabled and disabled with >>TURN, the compiler updates its list + * of enabled ECs (and any files they apply to). It encodes this list as an + * array of integers. parser_compile_ecs converts that array as a static + * compile-time vector, which it returns to the compiler. + * + * Before each statement, the compiler determines what possible EC handling the + * program can do. If there's an overlap between potential ECs and + * Declaratives, it passes the current pair of static arrays to + * parser_statement_begin(), which installs them, for that statement, in the + * library. + * + * After each statement, to effect EC handling, the statement epilog calls uses + * parser_match_exception to invoke __gg_match_exception(), which returns the + * symbol table index of the matched Declarative, if any. That "ladder" + * Performs the matched declarative, and execution continues with the next + * statement. + */ +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++); + tree retval = array_of_long_long(ach, ecs); + SHOW_IF_PARSE(nullptr) + { + SHOW_PARSE_HEADER + char ach[64]; + snprintf(ach, sizeof(ach), " Size is %lu; retval is %p", + gb4(ecs.size()), as_voidp(retval)); + SHOW_PARSE_TEXT(ach) + SHOW_PARSE_END + } + TRACE1 + { + TRACE1_HEADER + char ach[64]; + snprintf(ach, sizeof(ach), " Size is %lu; retval is %p", + gb4(ecs.size()), as_voidp(retval)); + TRACE1_TEXT_ABC("", ach, ""); + TRACE1_END + } + return retval; + } + +/* + * At the beginning of Procedure Division, we may encounter DECLARATIVES + * SECTION. If so, the compiler composes a list of zero or more Declaratives + * as cbl_declarative_t, representing the USE statement of each + * Declarative. These are encoded as an array of integers, which are returned + * to the compiler for use by parser_statement_begin(). Although the list of + * declaratives never changes for a program, CALL may change which program is + * 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 ) + { + 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 %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 %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) + { + 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 ) { SHOW_PARSE { SHOW_PARSE_HEADER char ach[64]; - snprintf (ach, sizeof(ach), + snprintf( ach, sizeof(ach), " yylineno %d first/last %d/%d", yylineno, cobol_location().first_line, cobol_location().last_line ); SHOW_PARSE_TEXT(ach); + if( true || ecs || dcls ) + { + SHOW_PARSE_INDENT + snprintf( ach, sizeof(ach), + "Sending ecs/dcls %p / %p", as_voidp(ecs), as_voidp(dcls)); + SHOW_PARSE_TEXT(ach); + } SHOW_PARSE_END } + TRACE1 + { + TRACE1_HEADER + char ach[64]; + 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 prevents anomolies when the first line of a program is - // a PERFORM <proc> ... TEST AFTER ... UNTIL ... + // This code is intended to prevert GDB anomalies when the first line of a + // program is a PERFORM <proc> ... TEST AFTER ... UNTIL ... gg_set_current_line_number(CURRENT_LINE_NUMBER-1); gg_assign(var_decl_nop, build_int_cst_type(INT, 106)); } + // 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); + + if( exception_processing ) + { + set_exception_environment(ecs, dcls); + } + sv_is_i_o = false; } static void @@ -1064,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) ) @@ -1085,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 ) @@ -1115,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 @@ -1126,7 +1417,7 @@ initialize_variable_internal( cbl_refer_t refer, gg_call(VOID, "__gg__initialize_variable", gg_get_address_of(refer.field->var_decl_node), - refer_offset_dest(refer), + refer_offset(refer), build_int_cst_type(INT, flag_bits), NULL_TREE); } @@ -1228,7 +1519,40 @@ initialize_variable_internal( cbl_refer_t refer, } else { - TRACE1_FIELD_VALUE("", parsed_var, "") + // Convert strings of spaces to "<SPACES>" + tree spaces = gg_define_int(0); + if( parsed_var->type == FldGroup + || parsed_var->type == FldAlphanumeric + || parsed_var->type == FldAlphaEdited + || parsed_var->type == FldLiteralA ) + { + gg_assign(spaces, integer_one_node); + tree counter = gg_define_int(parsed_var->data.capacity); + WHILE(counter, gt_op, integer_zero_node) + { + gg_decrement(counter); + IF( gg_indirect(member(parsed_var->var_decl_node, "data"), counter), + ne_op, + build_int_cst_type(UCHAR, ' ') ) + { + gg_assign(spaces, integer_zero_node); + } + ELSE + { + } + ENDIF + } + WEND + } + IF(spaces, eq_op, integer_one_node) + { + TRACE1_TEXT(" <SPACES>") + } + ELSE + { + TRACE1_FIELD_VALUE("", parsed_var, "") + } + ENDIF } TRACE1_END } @@ -1247,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 ) @@ -1344,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)); } } @@ -1482,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 ); @@ -1775,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(); @@ -1786,12 +2096,12 @@ compare_binary_binary(tree return_int, get_binary_value(left_side, NULL, left_side_ref->field, - refer_offset_source(*left_side_ref), + refer_offset(*left_side_ref), hilo_left); get_binary_value(right_side, NULL, right_side_ref->field, - refer_offset_source(*right_side_ref), + refer_offset(*right_side_ref), hilo_right); IF( hilo_left, eq_op, integer_one_node ) { @@ -1965,7 +2275,7 @@ cobol_compare( tree return_int, "__gg__literaln_alpha_compare", gg_string_literal(buffer), gg_get_address_of(righty->field->var_decl_node), - refer_offset_source(*righty), + refer_offset(*righty), refer_size_source( *righty), build_int_cst_type(INT, (righty->all ? REFER_T_MOVE_ALL : 0)), @@ -2028,23 +2338,26 @@ cobol_compare( tree return_int, { // None of our explicit comparisons up above worked, so we revert to the // general case: - int leftflags = (left_side_ref.all ? REFER_T_MOVE_ALL : 0) - + (left_side_ref.addr_of ? REFER_T_ADDRESS_OF : 0); - int rightflags = (right_side_ref.all ? REFER_T_MOVE_ALL : 0) - + (right_side_ref.addr_of ? REFER_T_ADDRESS_OF : 0); + int leftflags = (left_side_ref.all ? REFER_T_MOVE_ALL : 0) + + (left_side_ref.addr_of ? REFER_T_ADDRESS_OF : 0) + + (left_side_ref.refmod.from ? REFER_T_REFMOD : 0); + int rightflags = (right_side_ref.all ? REFER_T_MOVE_ALL : 0) + + (right_side_ref.addr_of ? REFER_T_ADDRESS_OF : 0) + + (right_side_ref.refmod.from ? REFER_T_REFMOD : 0); gg_assign( return_int, gg_call_expr( INT, "__gg__compare", gg_get_address_of(left_side_ref.field->var_decl_node), - refer_offset_source(left_side_ref), + refer_offset(left_side_ref), refer_size_source( left_side_ref), build_int_cst_type(INT, leftflags), gg_get_address_of(right_side_ref.field->var_decl_node), - refer_offset_source(right_side_ref), + refer_offset(right_side_ref), refer_size_source( right_side_ref), build_int_cst_type(INT, rightflags), integer_zero_node, NULL_TREE)); + compared = true; } // gg_printf(" result is %d\n", return_int, NULL_TREE); @@ -2168,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; } @@ -2202,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)); @@ -2237,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; } @@ -2254,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 ) @@ -2278,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 ) @@ -2306,9 +2619,11 @@ combined_name(cbl_label_t *label) { strcat(retval, mangled_program_name); } - sprintf(ach, ".%ld", current_function->program_id_number); + sprintf(ach, "." HOST_SIZE_T_PRINT_DEC, + (fmt_size_t)current_function->program_id_number); strcat(retval, ach); - sprintf(ach, ".%ld", symbol_label_id(label)); + sprintf(ach, "." HOST_SIZE_T_PRINT_DEC, + (fmt_size_t)symbol_label_id(label)); strcat(retval, ach); free(mangled_program_name); free(section); @@ -2354,10 +2669,11 @@ section_label(struct cbl_proc_t *procedure) cbl_label_t *label = procedure->label; // The _initialize_program section isn't relevant. - char *psz = xasprintf("# SECTION %s in %s (%ld)", + char *psz = xasprintf("%s SECTION %s in %s (" HOST_SIZE_T_PRINT_DEC ")", + ASM_COMMENT_START, label->name, current_function->our_unmangled_name, - deconflictor); + (fmt_size_t)deconflictor); gg_insert_into_assembler(psz); free(psz); @@ -2402,15 +2718,15 @@ paragraph_label(struct cbl_proc_t *procedure) char *section_name = section ? section->name : nullptr; size_t deconflictor = symbol_label_id(procedure->label); - - char *psz1 = + + char *psz1 = xasprintf( - "# PARAGRAPH %s of %s in %s (%ld)", + "%s PARAGRAPH %s of %s in %s (" HOST_SIZE_T_PRINT_DEC ")", + ASM_COMMENT_START, para_name ? para_name: "" , section_name ? section_name: "(null)" , current_function->our_unmangled_name ? current_function->our_unmangled_name: "" , - deconflictor ); - + (fmt_size_t)deconflictor ); gg_insert_into_assembler(psz1); SHOW_PARSE @@ -2521,8 +2837,8 @@ leave_procedure(struct cbl_proc_t *procedure, bool /*section*/) gg_append_statement(procedure->exit.label); char *psz; - psz = xasprintf("_procret.%ld:", - symbol_label_id(procedure->label)); + psz = xasprintf("_procret." HOST_SIZE_T_PRINT_DEC ":", + (fmt_size_t)symbol_label_id(procedure->label)); gg_insert_into_assembler(psz); free(psz); pseudo_return_pop(procedure); @@ -2896,7 +3212,7 @@ parser_goto( cbl_refer_t value_ref, size_t narg, cbl_label_t * const labels[] ) get_binary_value( value, NULL, value_ref.field, - refer_offset_source(value_ref)); + refer_offset(value_ref)); // Convert it from one-based to zero-based: gg_decrement(value); // Check to see if the value is in the range 0...narg-1: @@ -2991,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); @@ -3003,11 +3319,12 @@ parser_perform(cbl_label_t *label, bool suppress_nexting) para_name = label->name; sect_name = section_label->name; sprintf(ach, - "# PERFORM %s of %s of %s (%ld)", + "%s PERFORM %s of %s of %s (" HOST_SIZE_T_PRINT_DEC ")", + ASM_COMMENT_START, para_name, sect_name, program_name, - deconflictor); + (fmt_size_t)deconflictor); gg_insert_into_assembler(ach); } @@ -3015,18 +3332,19 @@ parser_perform(cbl_label_t *label, bool suppress_nexting) { sect_name = label->name; sprintf(ach, - "# PERFORM %s of %s (%ld)", + "%s PERFORM %s of %s (" HOST_SIZE_T_PRINT_DEC ")", + ASM_COMMENT_START, sect_name, program_name, - deconflictor); + (fmt_size_t)deconflictor); gg_insert_into_assembler(ach); } if( !suppress_nexting ) { sprintf(ach, - "_proccall.%ld.%d:", - symbol_label_id(label), + "_proccall." HOST_SIZE_T_PRINT_DEC ".%d:", + (fmt_size_t)symbol_label_id(label), call_counter++); gg_insert_into_assembler( ach ); } @@ -3074,8 +3392,8 @@ parser_perform_times( cbl_label_t *proc_1, cbl_refer_t count ) char ach[256]; size_t our_pseudo_label = pseudo_label++; sprintf(ach, - "_proccallb.%ld:", - our_pseudo_label); + "_proccallb." HOST_SIZE_T_PRINT_DEC ":", + (fmt_size_t)our_pseudo_label); gg_insert_into_assembler( ach ); tree counter = gg_define_variable(LONG); @@ -3084,7 +3402,7 @@ parser_perform_times( cbl_label_t *proc_1, cbl_refer_t count ) get_binary_value( counter, NULL, count.field, - refer_offset_source(count)); + refer_offset(count)); // Make sure the initial count is valid: WHILE( counter, gt_op, gg_cast(LONG, integer_zero_node) ) @@ -3096,8 +3414,8 @@ parser_perform_times( cbl_label_t *proc_1, cbl_refer_t count ) WEND sprintf(ach, - "_procretb.%ld:", - our_pseudo_label); + "_procretb." HOST_SIZE_T_PRINT_DEC ":", + (fmt_size_t)our_pseudo_label); gg_insert_into_assembler(ach); } @@ -3167,15 +3485,15 @@ 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("# PERFORM %s THROUGH %s", - proc_1->name, proc_2->name); + gg_insert_into_assemblerf("%s PERFORM %s THROUGH %s", + ASM_COMMENT_START, proc_1->name, proc_2->name); if( !suppress_nexting ) { char ach[256]; sprintf(ach, - "_proccall.%ld.%d:", - symbol_label_id(proc_2), + "_proccall." HOST_SIZE_T_PRINT_DEC ".%d:", + (fmt_size_t)symbol_label_id(proc_2), call_counter++); gg_insert_into_assembler(ach); } @@ -3224,15 +3542,15 @@ internal_perform_through_times( cbl_label_t *proc_1, char ach[256]; sprintf(ach, - "_proccallb.%ld:", - our_pseudo_label); + "_proccallb." HOST_SIZE_T_PRINT_DEC ":", + (fmt_size_t)our_pseudo_label); gg_insert_into_assembler( ach ); tree counter = gg_define_variable(LONG); get_binary_value( counter, NULL, count.field, - refer_offset_source(count)); + refer_offset(count)); WHILE( counter, gt_op, gg_cast(LONG, integer_zero_node) ) { internal_perform_through(proc_1, proc_2, true); // true means suppress_nexting @@ -3241,8 +3559,8 @@ internal_perform_through_times( cbl_label_t *proc_1, WEND sprintf(ach, - "_procretb.%ld:", - our_pseudo_label); + "_procretb." HOST_SIZE_T_PRINT_DEC ":", + (fmt_size_t)our_pseudo_label); gg_insert_into_assembler( ach ); } @@ -3317,8 +3635,6 @@ parser_first_statement( int lineno ) } } -#define linemap_add(...) - void parser_enter_file(const char *filename) { @@ -3350,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: @@ -3373,8 +3686,6 @@ parser_enter_file(const char *filename) A = gg_declare_variable(B, C, NULL_TREE, vs_external_reference) SET_VAR_DECL(var_decl_exception_code , INT , "__gg__exception_code"); - SET_VAR_DECL(var_decl_exception_handled , INT , "__gg__exception_handled"); - SET_VAR_DECL(var_decl_exception_file_number , INT , "__gg__exception_file_number"); SET_VAR_DECL(var_decl_exception_file_status , INT , "__gg__exception_file_status"); SET_VAR_DECL(var_decl_exception_file_name , CHAR_P , "__gg__exception_file_name"); SET_VAR_DECL(var_decl_exception_statement , CHAR_P , "__gg__exception_statement"); @@ -3386,7 +3697,6 @@ parser_enter_file(const char *filename) SET_VAR_DECL(var_decl_default_compute_error , INT , "__gg__default_compute_error"); SET_VAR_DECL(var_decl_rdigits , INT , "__gg__rdigits"); - SET_VAR_DECL(var_decl_odo_violation , INT , "__gg__odo_violation"); SET_VAR_DECL(var_decl_unique_prog_id , SIZE_T , "__gg__unique_prog_id"); SET_VAR_DECL(var_decl_entry_location , VOID_P , "__gg__entry_pointer"); @@ -3428,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 @@ -3452,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); @@ -3485,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. @@ -3546,19 +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.%ld", mangled_name, 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); @@ -3624,6 +3951,8 @@ parser_enter_program( const char *funcname_, TRACE1_TEXT("\"") TRACE1_END } + + free(funcname); } void @@ -3719,8 +4048,8 @@ parser_init_list_size(int count_of_variables) vti_list_size = count_of_variables; char ach[48]; sprintf(ach, - "..variables_to_init_%ld", - current_function->our_symbol_table_index); + "..variables_to_init_" HOST_SIZE_T_PRINT_DEC, + (fmt_size_t)current_function->our_symbol_table_index); tree array_of_variables_type = build_array_type_nelts(VOID_P, count_of_variables+1); vti_array = gg_define_variable( array_of_variables_type, @@ -3758,8 +4087,8 @@ parser_init_list() char ach[48]; sprintf(ach, - "..variables_to_init_%ld", - current_function->our_symbol_table_index); + "..variables_to_init_" HOST_SIZE_T_PRINT_DEC, + (fmt_size_t)current_function->our_symbol_table_index); tree array = gg_trans_unit_var_decl(ach); gg_call(VOID, "__gg__variables_to_init", @@ -3819,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'); @@ -3940,7 +4269,7 @@ psa_FldLiteralN(struct cbl_field_t *field ) static size_t our_index = 0; - sprintf(id_string, ".%ld", ++our_index); + sprintf(id_string, "." HOST_SIZE_T_PRINT_DEC, (fmt_size_t)++our_index); strcpy(base_name, field->name); strcat(base_name, id_string); @@ -3955,6 +4284,11 @@ psa_FldLiteralN(struct cbl_field_t *field ) vs_static); DECL_INITIAL(new_var_decl) = wide_int_to_tree(var_type, value); field->data_decl_node = new_var_decl; + + // Note that during compilation, the integer value, assuming it can be + // contained in 128-bit integers, can be accessed with + // + // wi::to_wide( DECL_INITIAL(new_var_decl) ) } static void @@ -3977,7 +4311,7 @@ psa_FldBlob(struct cbl_field_t *var ) static size_t our_index = 0; - sprintf(id_string, ".%ld", ++our_index); + sprintf(id_string, "." HOST_SIZE_T_PRINT_DEC, (fmt_size_t)++our_index); strcpy(base_name, var->name); strcat(base_name, id_string); @@ -4063,7 +4397,7 @@ parser_accept( struct cbl_refer_t refer, "__gg__accept", environment, gg_get_address_of(refer.field->var_decl_node), - refer_offset_dest(refer), + refer_offset(refer), refer_size_dest(refer), NULL_TREE); } @@ -4154,7 +4488,7 @@ parser_accept_command_line( cbl_refer_t tgt, gg_call_expr( INT, "__gg__get_command_line", gg_get_address_of(tgt.field->var_decl_node), - refer_offset_dest(tgt), + refer_offset(tgt), refer_size_dest(tgt), NULL_TREE)); if( error ) @@ -4201,10 +4535,10 @@ parser_accept_command_line( cbl_refer_t tgt, gg_call_expr( INT, "__gg__get_argv", gg_get_address_of(tgt.field->var_decl_node), - refer_offset_dest(tgt), + refer_offset(tgt), refer_size_dest(tgt), gg_get_address_of(source.field->var_decl_node), - refer_offset_dest(source), + refer_offset(source), refer_size_dest(source), NULL_TREE)); if( error ) @@ -4284,7 +4618,7 @@ parser_accept_command_line_count( cbl_refer_t tgt ) gg_call( VOID, "__gg__get_argc", gg_get_address_of(tgt.field->var_decl_node), - refer_offset_dest(tgt), + refer_offset(tgt), refer_size_dest(tgt), NULL_TREE); } @@ -4322,10 +4656,10 @@ parser_accept_envar(struct cbl_refer_t tgt, gg_call_expr( INT, "__gg__accept_envar", gg_get_address_of(tgt.field->var_decl_node), - refer_offset_dest(tgt), + refer_offset(tgt), refer_size_dest(tgt), gg_get_address_of(envar.field->var_decl_node), - refer_offset_source(envar), + refer_offset(envar), refer_size_source(envar), NULL_TREE)); if( error ) @@ -4394,10 +4728,10 @@ parser_set_envar( struct cbl_refer_t name, struct cbl_refer_t value ) gg_call(BOOL, "__gg__set_envar", gg_get_address_of(name.field->var_decl_node), - refer_offset_source(name), + refer_offset(name), refer_size_source(name), gg_get_address_of(value.field->var_decl_node), - refer_offset_source(value), + refer_offset(value), refer_size_source(value), NULL_TREE); } @@ -4894,7 +5228,7 @@ parser_display_internal(tree file_descriptor, gg_call(VOID, "__gg__display", gg_get_address_of(refer.field->var_decl_node), - refer_offset_source(refer), + refer_offset(refer), refer_size_source( refer), file_descriptor, advance ? integer_one_node : integer_zero_node, @@ -4916,6 +5250,16 @@ parser_display_field(cbl_field_t *field) DISPLAY_NO_ADVANCE); } +/* + * The first parameter to parser_display is the "device" upon which to display + * the data. Besides normal devices, these may include elements that define the + * Unix command line and environment: + * 1. ARG_NUM_e, the ARGUMENT-NUMBER + * 2. ARG_VALUE_e, the ARGUMENT-VALUE + * 3. ENV_NAME_e, the ENVIRONMENT-NAME + * 4. ENV_VALUE_e, the ENVIRONMENT-VALUE + * that need special care and feeding. + */ void parser_display( const struct cbl_special_name_t *upon, struct cbl_refer_t refs[], @@ -4976,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] ) { @@ -5048,7 +5404,8 @@ parser_assign( size_t nC, cbl_num_result_t *C, { TRACE1_HEADER char ach[32]; - sprintf(ach, "%ld target%s", nC, nC==1 ? "" : "s"); + sprintf(ach, HOST_SIZE_T_PRINT_DEC " target%s", + (fmt_size_t)nC, nC==1 ? "" : "s"); TRACE1_TEXT(ach); if( on_error ) { @@ -5067,7 +5424,8 @@ parser_assign( size_t nC, cbl_num_result_t *C, TRACE1 { char ach[48]; - sprintf(ach, "Processing target number %ld", i); + sprintf(ach, "Processing target number " HOST_SIZE_T_PRINT_DEC, + (fmt_size_t)i); TRACE1_INDENT TRACE1_TEXT(ach); } @@ -5354,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 @@ -5626,7 +5984,7 @@ parser_initialize_table(size_t nelem, "__gg__mirror_range", build_int_cst_type(SIZE_T, nelem), gg_get_address_of(src.field->var_decl_node), - refer_offset_source(src), + refer_offset(src), build_int_cst_type(SIZE_T, nspan), tspans, build_int_cst_type(SIZE_T, table), @@ -5664,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; @@ -5717,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; } @@ -5745,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: @@ -5763,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: @@ -5773,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; } @@ -5782,13 +6142,13 @@ void parser_sleep(cbl_refer_t seconds) if( seconds.field ) { gg_get_address_of(seconds.field->var_decl_node); - //refer_offset_source(seconds); + //refer_offset(seconds); //refer_size_source(seconds); gg_call(VOID, "__gg__sleep", gg_get_address_of(seconds.field->var_decl_node), - refer_offset_source(seconds), + refer_offset(seconds), refer_size_source(seconds), NULL_TREE); } @@ -5817,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;". @@ -5840,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. @@ -5908,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 @@ -5945,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 { @@ -5956,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 { @@ -5981,7 +6338,7 @@ parser_exit( cbl_refer_t refer, ec_type_t ec ) { } ENDIF - pe_stuff(refer, ec); + program_end_stuff(refer, ec); } } @@ -6096,14 +6453,14 @@ parser_allocate(cbl_refer_t size_or_based, gg_call(VOID, "__gg__allocate", gg_get_address_of(size_or_based.field->var_decl_node), - refer_offset_source(size_or_based) , + refer_offset(size_or_based) , initialized ? integer_one_node : integer_zero_node, build_int_cst_type(INT, default_byte), f_working ? gg_get_address_of(f_working->var_decl_node) : null_pointer_node, f_local ? gg_get_address_of(f_local-> var_decl_node) : null_pointer_node, returning.field ? gg_get_address_of(returning.field->var_decl_node) : null_pointer_node, - returning.field ? refer_offset_source(returning) + returning.field ? refer_offset(returning) : size_t_zero_node, NULL_TREE); walk_initialization(size_or_based.field, initialized, false); @@ -6121,14 +6478,15 @@ parser_free( size_t n, cbl_refer_t refers[] ) gcc_assert( ! p->is_refmod_reference() ); if( !(p->field->type == FldPointer || p->addr_of || (p->field->attr & based_e)) ) { - dbgmsg("Deallocating %s means it has to be FldPointer or addr_of or based_e"); + dbgmsg("Deallocating %s means it has to be FldPointer or addr_of or based_e", + p->field->name); } gcc_assert( p->field->type == FldPointer || p->addr_of || (p->field->attr & based_e) ); gg_call(VOID, "__gg__deallocate", gg_get_address_of(p->field->var_decl_node), - refer_offset_source(*p), + refer_offset(*p), p->addr_of ? integer_one_node : integer_zero_node, NULL_TREE); walk_initialization(p->field, false, true); @@ -6395,8 +6753,8 @@ parser_division(cbl_division_t division, // We need a pointer to the array of program names char ach[2*sizeof(cbl_name_t)]; sprintf(ach, - "..accessible_program_list_%ld", - current_function->our_symbol_table_index); + "..accessible_program_list_" HOST_SIZE_T_PRINT_DEC, + (fmt_size_t)current_function->our_symbol_table_index); tree prog_list = gg_define_variable(build_pointer_type(CHAR_P), ach, vs_file_static); @@ -6408,8 +6766,8 @@ parser_division(cbl_division_t division, tree pointer_type = build_pointer_type(function_type); tree constructed_array_type = build_array_type_nelts(pointer_type, 1); sprintf(ach, - "..accessible_program_pointers_%ld", - current_function->our_symbol_table_index); + "..accessible_program_pointers_" HOST_SIZE_T_PRINT_DEC, + (fmt_size_t)current_function->our_symbol_table_index); tree prog_pointers = gg_define_variable( build_pointer_type(constructed_array_type), ach, @@ -6471,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 @@ -6492,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() @@ -6588,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++) { @@ -6629,27 +6991,11 @@ parser_division(cbl_division_t division, } gg_assign(base, gg_cast(UCHAR_P, parameter)); - IF( gg_call_expr( CHAR_P, - "getenv", - gg_string_literal("PARAMETERS_ON_ENTRY"), - NULL_TREE), - ne_op, - gg_cast(CHAR_P, null_pointer_node)); - { - gg_printf("parameter_on_entry: %s(): %d %p\n", - gg_string_literal(current_function->our_unmangled_name), - build_int_cst_type(INT, i+1), - base, - NULL_TREE); - } - ELSE - ENDIF - if( args[i].refer.field->attr & any_length_e ) { - // gg_printf("side channel: Length of \"%s\" is %ld\n", + // gg_printf("side channel: Length of \"%s\" is %ld\n", // member(args[i].refer.field->var_decl_node, "name"), - // gg_array_value(var_decl_call_parameter_lengths, rt_i), + // gg_array_value(var_decl_call_parameter_lengths, rt_i), // NULL_TREE); // Get the length from the global lengths[] side channel. Don't @@ -6934,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); } @@ -7053,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); @@ -7117,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); } @@ -7127,7 +7473,7 @@ parser_relop_long(cbl_field_t *tgt, get_binary_value( tree_b, NULL, bref.field, - refer_offset_source(bref) ); + refer_offset(bref) ); static tree comp_res = gg_define_variable(LONG, "..prl_comp_res", vs_file_static); gg_assign(comp_res, gg_subtract(tree_a, tree_b)); @@ -7163,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); } @@ -7249,7 +7595,7 @@ parser_see_stop_run(struct cbl_refer_t exit_status, get_binary_value( returned_value, NULL, exit_status.field, - refer_offset_source(exit_status)); + refer_offset(exit_status)); TRACE1 { TRACE1_REFER(" exit_status ", exit_status, "") @@ -7414,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; } @@ -7464,7 +7809,7 @@ parser_classify( cbl_field_t *tgt, "__gg__classify", build_int_cst_type(INT, type), gg_get_address_of(candidate.field->var_decl_node), - refer_offset_dest(candidate), + refer_offset(candidate), refer_size_dest(candidate), NULL_TREE), ne_op, @@ -7480,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() ) { @@ -7619,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); @@ -7668,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 @@ -7728,8 +8074,8 @@ perform_outofline_before_until(struct cbl_perform_tgt_t *tgt, char ach[256]; size_t our_pseudo_label = pseudo_label++; sprintf(ach, - "_proccallb.%ld:", - our_pseudo_label); + "_proccallb." HOST_SIZE_T_PRINT_DEC ":", + (fmt_size_t)our_pseudo_label); gg_insert_into_assembler( ach ); parser_if(varys[0].until); @@ -7751,8 +8097,8 @@ perform_outofline_before_until(struct cbl_perform_tgt_t *tgt, // Label the bottom of the PERFORM gg_append_statement( tgt->addresses.exit.label ); sprintf(ach, - "_procretb.%ld:", - our_pseudo_label); + "_procretb." HOST_SIZE_T_PRINT_DEC ":", + (fmt_size_t)our_pseudo_label); gg_insert_into_assembler( ach ); } @@ -7783,8 +8129,8 @@ perform_outofline_after_until(struct cbl_perform_tgt_t *tgt, char ach[256]; size_t our_pseudo_label = pseudo_label++; sprintf(ach, - "_proccallb.%ld:", - our_pseudo_label); + "_proccallb." HOST_SIZE_T_PRINT_DEC ":", + (fmt_size_t)our_pseudo_label); gg_insert_into_assembler( ach ); create_iline_address_pairs(tgt); @@ -7814,8 +8160,8 @@ perform_outofline_after_until(struct cbl_perform_tgt_t *tgt, // Label the bottom of the PERFORM gg_append_statement( tgt->addresses.exit.label ); sprintf(ach, - "_procretb.%ld:", - our_pseudo_label); + "_procretb." HOST_SIZE_T_PRINT_DEC ":", + (fmt_size_t)our_pseudo_label); gg_insert_into_assembler( ach ); } @@ -7879,8 +8225,8 @@ perform_outofline_testafter_varying(struct cbl_perform_tgt_t *tgt, char ach[256]; size_t our_pseudo_label = pseudo_label++; sprintf(ach, - "_proccallb.%ld:", - our_pseudo_label); + "_proccallb." HOST_SIZE_T_PRINT_DEC ":", + (fmt_size_t)our_pseudo_label); gg_insert_into_assembler( ach ); create_iline_address_pairs(tgt); @@ -7934,8 +8280,8 @@ perform_outofline_testafter_varying(struct cbl_perform_tgt_t *tgt, // Arriving here means that we all of the conditions were // true. So, we're done. sprintf(ach, - "_procretb.%ld:", - our_pseudo_label); + "_procretb." HOST_SIZE_T_PRINT_DEC ":", + (fmt_size_t)our_pseudo_label); gg_insert_into_assembler( ach ); } @@ -7996,8 +8342,8 @@ perform_outofline_before_varying( struct cbl_perform_tgt_t *tgt, char ach[256]; size_t our_pseudo_label = pseudo_label++; sprintf(ach, - "_proccallb.%ld:", - our_pseudo_label); + "_proccallb." HOST_SIZE_T_PRINT_DEC ":", + (fmt_size_t)our_pseudo_label); gg_insert_into_assembler( ach ); // Initialize all varying: @@ -8077,8 +8423,8 @@ perform_outofline_before_varying( struct cbl_perform_tgt_t *tgt, // We have, you see, reached the egress: gg_append_statement( tgt->addresses.exit.label ); sprintf(ach, - "_procretb.%ld:", - our_pseudo_label); + "_procretb." HOST_SIZE_T_PRINT_DEC ":", + (fmt_size_t)our_pseudo_label); gg_insert_into_assembler( ach ); } @@ -8285,7 +8631,7 @@ perform_inline_testbefore_varying( struct cbl_perform_tgt_t *tgt, { SHOW_PARSE_INDENT char ach[32]; - sprintf(ach, "LABEL [%ld]:", i); + sprintf(ach, "LABEL [" HOST_SIZE_T_PRINT_DEC "]:", (fmt_size_t)i); SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } @@ -8296,7 +8642,8 @@ perform_inline_testbefore_varying( struct cbl_perform_tgt_t *tgt, { SHOW_PARSE_INDENT char ach[32]; - sprintf(ach, "LABEL CONDINTO[%ld]:", i); + sprintf(ach, "LABEL CONDINTO[" HOST_SIZE_T_PRINT_DEC "]:", + (fmt_size_t)i); SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } @@ -8307,7 +8654,8 @@ perform_inline_testbefore_varying( struct cbl_perform_tgt_t *tgt, { SHOW_PARSE_INDENT char ach[32]; - sprintf(ach, "LABEL CONDBACK[%ld]:", i); + sprintf(ach, "LABEL CONDBACK[" HOST_SIZE_T_PRINT_DEC "]:", + (fmt_size_t)i); SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } @@ -8342,7 +8690,8 @@ perform_inline_testbefore_varying( struct cbl_perform_tgt_t *tgt, { SHOW_PARSE_INDENT char ach[32]; - sprintf(ach, "GOTO [%ld]:", i-1); + sprintf(ach, "GOTO [" HOST_SIZE_T_PRINT_DEC "]:", + (fmt_size_t)(i-1)); SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } @@ -8376,7 +8725,8 @@ perform_inline_testbefore_varying( struct cbl_perform_tgt_t *tgt, { SHOW_PARSE_INDENT char ach[32]; - sprintf(ach, "GOTO [%ld]:", N-1); + sprintf(ach, "GOTO [" HOST_SIZE_T_PRINT_DEC "]:", + (fmt_size_t)(N-1)); SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } @@ -8393,7 +8743,8 @@ perform_inline_testbefore_varying( struct cbl_perform_tgt_t *tgt, { SHOW_PARSE_INDENT char ach[32]; - sprintf(ach, "GOTO [%ld]:", i-1); + sprintf(ach, "GOTO [" HOST_SIZE_T_PRINT_DEC "]:", + (fmt_size_t)(i-1)); SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } @@ -8739,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; @@ -8851,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); } @@ -8976,17 +9327,20 @@ 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, __func__); } + size_t symbol_table_index = symbol_index(symbol_elem_of(file)); + gg_call(VOID, "__gg__file_init", gg_get_address_of(new_var_decl), gg_string_literal(file->name), + build_int_cst_type(SIZE_T, symbol_table_index), array_of_keys, key_numbers, unique_flags, @@ -9007,8 +9361,6 @@ parser_file_add(struct cbl_file_t *file) file->var_decl_node = new_var_decl; } -static void store_location_stuff(const cbl_name_t statement_name); - void parser_file_open( size_t nfiles, struct cbl_file_t *files[], int mode_char ) { @@ -9049,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) ) @@ -9095,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", @@ -9127,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 @@ -9146,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", @@ -9195,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); @@ -9224,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", @@ -9311,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); } @@ -9339,7 +9698,7 @@ parser_file_write( cbl_file_t *file, get_binary_value( value, NULL, advance.field, - refer_offset_source(advance)); + refer_offset(advance)); gg_assign(t_advance, gg_cast(INT, value)); } else @@ -9365,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", @@ -9434,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", @@ -9490,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", @@ -9596,9 +9958,10 @@ parser_file_start(struct cbl_file_t *file, get_binary_value( length, NULL, length_ref.field, - refer_offset_dest(length_ref)); + refer_offset(length_ref)); } + sv_is_i_o = true; store_location_stuff("START"); gg_call(VOID, "__gg__file_start", @@ -9613,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 } @@ -9630,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++; @@ -9643,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: @@ -9659,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++; @@ -9695,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; @@ -9715,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; } } } @@ -9754,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, @@ -9762,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 @@ -9782,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; @@ -9792,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 @@ -9813,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(); } } @@ -9827,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); @@ -9848,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; @@ -9861,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 { @@ -9890,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 } @@ -9906,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 { @@ -9926,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 } @@ -9942,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. @@ -9959,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, @@ -9970,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, - unsigned long 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 @@ -9986,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); } } @@ -10015,27 +10420,27 @@ parser_inspect_conv(cbl_refer_t input, backward ? integer_one_node : integer_zero_node, input.field ? gg_get_address_of(input.field->var_decl_node) : null_pointer_node, - refer_offset_source(input), + refer_offset(input), refer_size_source(input), original.field ? gg_get_address_of(original.field->var_decl_node) : null_pointer_node, - refer_offset_dest(original), + refer_offset(original), refer_size_dest(original), replacement.field ? gg_get_address_of( replacement.field->var_decl_node) : null_pointer_node, - refer_offset_source(replacement), + refer_offset(replacement), replacement.all ? build_int_cst_type(SIZE_T, -1LL) : refer_size_source(replacement), after.identifier_4.field ? gg_get_address_of( after.identifier_4.field->var_decl_node) : null_pointer_node, - refer_offset_source(after.identifier_4), + refer_offset(after.identifier_4), refer_size_source(after.identifier_4), before.identifier_4.field ? gg_get_address_of( before.identifier_4.field->var_decl_node) : null_pointer_node, - refer_offset_source(before.identifier_4), + refer_offset(before.identifier_4), refer_size_source(before.identifier_4), NULL_TREE ); @@ -10085,10 +10490,10 @@ parser_intrinsic_numval_c( cbl_field_t *f, "__gg__test_numval_c", gg_get_address_of(f->var_decl_node), gg_get_address_of(input.field->var_decl_node), - refer_offset_source(input), + refer_offset(input), refer_size_source(input), currency.field ? gg_get_address_of(currency.field->var_decl_node) : null_pointer_node, - refer_offset_source(currency), + refer_offset(currency), refer_size_source(currency), NULL_TREE ); @@ -10099,10 +10504,10 @@ parser_intrinsic_numval_c( cbl_field_t *f, "__gg__numval_c", gg_get_address_of(f->var_decl_node), gg_get_address_of(input.field->var_decl_node), - refer_offset_source(input), + refer_offset(input), refer_size_source(input), currency.field ? gg_get_address_of(currency.field->var_decl_node) : null_pointer_node, - refer_offset_source(currency), + refer_offset(currency), refer_size_source(currency), NULL_TREE ); @@ -10134,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++) { @@ -10153,14 +10559,14 @@ 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", gg_get_address_of(f->var_decl_node), gg_get_address_of(ref1.field->var_decl_node), - refer_offset_source(ref1), + refer_offset(ref1), refer_size_source(ref1), build_int_cst_type(SIZE_T, argc), control, @@ -10168,8 +10574,6 @@ parser_intrinsic_subst( cbl_field_t *f, gg_free(control); - free(arg2); - free(arg1); free(control_bytes); } @@ -10193,7 +10597,8 @@ parser_intrinsic_callv( cbl_field_t *tgt, SHOW_PARSE_HEADER SHOW_PARSE_TEXT(" of ") SHOW_PARSE_TEXT(function_name) - fprintf(stderr, " with %zd parameters", nrefs); + fprintf(stderr, " with " HOST_SIZE_T_PRINT_DEC " parameters", + (fmt_size_t)nrefs); SHOW_PARSE_END } @@ -10262,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, @@ -10317,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), @@ -10381,7 +10788,7 @@ parser_intrinsic_call_1( cbl_field_t *tgt, function_name, gg_get_address_of(tgt->var_decl_node), gg_get_address_of(ref1.field->var_decl_node), - refer_offset_source(ref1), + refer_offset(ref1), refer_size_source(ref1), NULL_TREE); } @@ -10424,10 +10831,10 @@ parser_intrinsic_call_2( cbl_field_t *tgt, function_name, gg_get_address_of(tgt->var_decl_node), gg_get_address_of(ref1.field->var_decl_node), - refer_offset_source(ref1), + refer_offset(ref1), refer_size_source(ref1), ref2.field ? gg_get_address_of(ref2.field->var_decl_node) : null_pointer_node, - refer_offset_source(ref2), + refer_offset(ref2), refer_size_source(ref2), NULL_TREE); TRACE1 @@ -10474,13 +10881,13 @@ parser_intrinsic_call_3( cbl_field_t *tgt, function_name, gg_get_address_of(tgt->var_decl_node), ref1.field ? gg_get_address_of(ref1.field->var_decl_node) : null_pointer_node, - refer_offset_source(ref1), + refer_offset(ref1), refer_size_source(ref1), ref2.field ? gg_get_address_of(ref2.field->var_decl_node) : null_pointer_node, - refer_offset_source(ref2), + refer_offset(ref2), refer_size_source(ref2), ref3.field ? gg_get_address_of(ref3.field->var_decl_node) : null_pointer_node, - refer_offset_source(ref3), + refer_offset(ref3), refer_size_source(ref3), NULL_TREE); TRACE1 @@ -10529,16 +10936,16 @@ parser_intrinsic_call_4( cbl_field_t *tgt, function_name, gg_get_address_of(tgt->var_decl_node), ref1.field ? gg_get_address_of(ref1.field->var_decl_node) : null_pointer_node, - refer_offset_source(ref1), + refer_offset(ref1), refer_size_source(ref1), ref2.field ? gg_get_address_of(ref2.field->var_decl_node) : null_pointer_node, - refer_offset_source(ref2), + refer_offset(ref2), refer_size_source(ref2), ref3.field ? gg_get_address_of(ref3.field->var_decl_node) : null_pointer_node, - refer_offset_source(ref3), + refer_offset(ref3), refer_size_source(ref3), ref4.field ? gg_get_address_of(ref4.field->var_decl_node) : null_pointer_node, - refer_offset_source(ref4), + refer_offset(ref4), refer_size_source(ref4), NULL_TREE); TRACE1 @@ -10635,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); @@ -10872,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(); @@ -10961,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; @@ -10982,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 ) @@ -11108,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 @@ -11127,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; @@ -11151,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 ) { @@ -11167,7 +11574,7 @@ parser_sort(cbl_refer_t tableref, gg_call(VOID, "__gg__sort_table", gg_get_address_of(tableref.field->var_decl_node), - refer_offset_source(tableref), + refer_offset(tableref), gg_cast(SIZE_T, depending_on), build_int_cst_type(SIZE_T, key_index), all_keys, @@ -11190,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, @@ -11255,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__); } @@ -11268,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; @@ -11288,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 ); @@ -11384,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__); } } @@ -11463,7 +11870,13 @@ parser_return_start( cbl_file_t *workfile, cbl_refer_t into ) IF( member(workfile, "io_status"), lt_op, build_int_cst(INT, FsKeySeq) ) { - // The read didn't succeed because of an end-of-file condition + // The read didn't succeed because of an end-of-file condition. + + // Because there is an AT END clause, we suppress the error condition that + // was raised. + gg_assign(var_decl_exception_code, integer_zero_node); + + // And then we jump to the at_end code: gg_append_statement(workfile->addresses->at_end.go_to); } ELSE @@ -11584,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, @@ -11608,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; @@ -11630,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); @@ -11697,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), @@ -11791,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__); } } @@ -11869,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++) @@ -11881,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); @@ -11891,21 +12303,20 @@ parser_unstring(cbl_refer_t src, gg_call_expr( INT, "__gg__unstring", gg_get_address_of(src.field->var_decl_node), - refer_offset_source(src), + refer_offset(src), refer_size_source(src), build_int_cst_type(SIZE_T, ndelimited), t_alls, build_int_cst_type(SIZE_T, noutputs), pointer.field ? gg_get_address_of(pointer.field->var_decl_node) : null_pointer_node, - refer_offset_dest(pointer), + refer_offset(pointer), refer_size_dest(pointer), tally.field ? gg_get_address_of(tally.field->var_decl_node) : null_pointer_node, - refer_offset_dest(tally), + refer_offset(tally), refer_size_dest(tally), NULL_TREE) ); free(alls); - free(delims); if( overflow ) { @@ -11941,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 { @@ -11972,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; @@ -11997,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, @@ -12007,7 +12418,6 @@ parser_string( cbl_refer_t tgt, gg_free(pintegers); free(integers); - free(refers); if( overflow ) { @@ -12104,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; @@ -12167,7 +12577,7 @@ create_and_call(size_t narg, else { gg_assign(location, - qualified_data_source(args[i].refer)), + qualified_data_location(args[i].refer)), gg_assign(length, refer_size_source(args[i].refer)); } @@ -12296,7 +12706,7 @@ create_and_call(size_t narg, INT128, "__gg__fetch_call_by_value_value", gg_get_address_of(args[i].refer.field->var_decl_node), - refer_offset_source(args[i].refer), + refer_offset(args[i].refer), refer_size_source(args[i].refer), NULL_TREE))); } @@ -12309,7 +12719,7 @@ create_and_call(size_t narg, INT128, "__gg__fetch_call_by_value_value", gg_get_address_of(args[i].refer.field->var_decl_node), - refer_offset_source(args[i].refer), + refer_offset(args[i].refer), refer_size_source(args[i].refer), NULL_TREE))); } @@ -12329,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(); @@ -12358,9 +12807,9 @@ create_and_call(size_t narg, // we were given a returned::field, so find its location and length: gg_assign(returned_location, gg_add( member(returned.field->var_decl_node, "data"), - refer_offset_dest(returned))); + refer_offset(returned))); gg_assign(returned_length, - refer_size_dest(returned)); + gg_cast(TREE_TYPE(returned_length), refer_size_dest(returned))); // The returned value is a string of nbytes, which by specification // has to be at least as long as the returned_length of the target: @@ -12378,7 +12827,7 @@ create_and_call(size_t narg, { // There is a valid pointer. Do the assignment. move_tree(returned.field, - refer_offset_dest(returned), + refer_offset(returned), returned_value, integer_one_node); } @@ -12402,7 +12851,7 @@ create_and_call(size_t narg, gg_call(VOID, "__gg__int128_to_qualified_field", gg_get_address_of(returned.field->var_decl_node), - refer_offset_dest(returned), + refer_offset(returned), refer_size_dest(returned), gg_cast(INT128, returned_value), gg_cast(INT, member(returned.field->var_decl_node, "rdigits")), @@ -12424,7 +12873,7 @@ create_and_call(size_t narg, tree returned_length = gg_define_size_t(); // we were given a returned::field, so find its location and length: gg_assign(returned_location, - qualified_data_source(returned)); + qualified_data_location(returned)); gg_assign(returned_length, refer_size_source(returned)); @@ -12444,34 +12893,15 @@ 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__); } } else { - // Because no explicit returning value is expected, we switch to - // the IBM default behavior, where the returned INT value is assigned - // to our RETURN-CODE: - returned_value = gg_define_variable(SHORT); - - // Before doing the call, we save the COBOL program_state: - push_program_state(); - gg_assign(returned_value, gg_cast(SHORT, call_expr)); - // And after the call, we restore it: - pop_program_state(); - - // We know that the returned value is a 2-byte little-endian INT: - gg_assign( var_decl_return_code, - returned_value); - TRACE1 - { - TRACE1_HEADER - gg_printf("returned value: %d", - gg_cast(INT, var_decl_return_code), - NULL_TREE); - TRACE1_END - } + // Because no explicit returning value is expected, we just call it. We + // expect COBOL routines to set RETURN-CODE when they think it necessary. + gg_append_statement(call_expr); } for( size_t i=0; i<narg; i++ ) @@ -12518,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(" )") @@ -12579,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) ) + { + // name is a literal + create_and_call(narg, + args, + NULL_TREE, + name.field->data.initial, + returned_value_type, + returned, + not_except); + } + else if( name.field && name.field->type == FldPointer ) { - // If these conditions are true, then we know we have a good - // function_handle, and we don't need to check + tree function_pointer = function_pointer_from_name( name, + returned_value_type); + // This is call-by-pointer; we know function_pointer is good: create_and_call(narg, args, - function_handle, + function_pointer, + nullptr, returned_value_type, returned, - not_except - ); + not_except); } else { + tree function_pointer = function_pointer_from_name( name, + returned_value_type); // We might not have a good handle, so we have to check: - IF( function_handle, + IF( function_pointer, ne_op, - gg_cast(TREE_TYPE(function_handle), null_pointer_node) ) + gg_cast(TREE_TYPE(function_pointer), null_pointer_node) ) { - create_and_call(narg, - args, - function_handle, - returned_value_type, - returned, - not_except - ); + create_and_call(narg, + args, + function_pointer, + nullptr, + returned_value_type, + returned, + not_except); } ELSE { @@ -12659,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. @@ -12694,7 +13132,7 @@ parser_bitop( struct cbl_field_t *tgt, // tgt has to be a FldConditional { SHOW_PARSE_HEADER SHOW_PARSE_FIELD( " switch: ", a) - fprintf(stderr, " mask: %lx", bitmask); + fprintf(stderr, " mask: " HOST_SIZE_T_PRINT_HEX_PURE, (fmt_size_t)bitmask); fprintf(stderr, " op: %s", ops[op]); SHOW_PARSE_FIELD( " target ", tgt) SHOW_PARSE_END @@ -12703,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)); @@ -12740,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(); @@ -12778,7 +13216,7 @@ parser_bitwise_op(struct cbl_field_t *tgt, { SHOW_PARSE_HEADER SHOW_PARSE_FIELD( " switch: ", a) - fprintf(stderr, " mask: %lx", bitmask); + fprintf(stderr, " mask: " HOST_SIZE_T_PRINT_HEX_PURE, (fmt_size_t)bitmask); fprintf(stderr, " op: %s", ops[op]); SHOW_PARSE_FIELD( " target ", tgt) SHOW_PARSE_END @@ -12787,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)); @@ -12801,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(); @@ -12856,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_dest(tgts[i]), - gg_get_address_of(function_handle), + gg_memcpy(qualified_data_location(tgts[i]), + gg_get_address_of(function_pointer), sizeof_pointer); } else @@ -12878,10 +13316,10 @@ parser_set_pointers( size_t ntgt, cbl_refer_t *tgts, cbl_refer_t source ) gg_call( VOID, "__gg__set_pointer", gg_get_address_of(tgts[i].field->var_decl_node), - refer_offset_dest(tgts[i]), + refer_offset(tgts[i]), build_int_cst_type(INT, tgts[i].addr_of ? REFER_T_ADDRESS_OF : 0), source.field ? gg_get_address_of(source.field->var_decl_node) : null_pointer_node, - refer_offset_source(source), + refer_offset(source), build_int_cst_type(INT, source.addr_of ? REFER_T_ADDRESS_OF : 0), NULL_TREE ); @@ -12908,7 +13346,8 @@ typedef struct hier_node hier_node() : our_index(0), common(false), - parent_node(NULL) + parent_node(nullptr), + name(nullptr) {} } hier_node; @@ -12952,14 +13391,14 @@ 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(); - /* The complication in this routine is that it gets called near the end - of every program-id. And it keeps growing. The reason is because the - parser doesn't know when it is working on the last program of a list of - nested programs. So, we just do what we need to do, and we keep track - of what we've already built so that we don't build it more than once. + /* This routine gets called near the end of every program-id. It keeps + growing because the parser doesn't know when it is working on the last + program of a list of nested programs. So, we just do what we need to do, + and we keep track of what we've already built so that we don't build it + more than once. */ SHOW_PARSE { @@ -12970,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 ) { @@ -12982,11 +13421,11 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) } char ach[128]; sprintf(ach, - "%ld %s%s parent:%ld", - hier.labels[i].ordinal, + HOST_SIZE_T_PRINT_DEC " %s%s parent:" HOST_SIZE_T_PRINT_DEC, + (fmt_size_t)hier.labels[i].ordinal, hier.labels[i].label.name, hier.labels[i].label.common ? " COMMON" : "", - hier.labels[i].label.parent); + (fmt_size_t)hier.labels[i].label.parent); SHOW_PARSE_TEXT(ach); } } @@ -13025,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; @@ -13039,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); @@ -13113,14 +13552,16 @@ 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_%ld", caller); + sprintf(ach, "..our_accessible_functions_" HOST_SIZE_T_PRINT_DEC, + (fmt_size_t)caller); tree the_names_table = gg_define_variable(names_table_type, ach, vs_file_static); // Here is where we build a table out of constructors: tree constructed_array_type = build_array_type_nelts(pointer_type, mol->second.size()); - sprintf(ach, "..our_constructed_table_%ld", caller); + sprintf(ach, "..our_constructed_table_" HOST_SIZE_T_PRINT_DEC, + (fmt_size_t)caller); tree the_constructed_table = gg_define_variable(constructed_array_type, ach, vs_file_static); tree constr_names = make_node(CONSTRUCTOR); @@ -13138,7 +13579,10 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) callee != mol->second.end(); callee++ ) { - sprintf(ach, "%s.%ld", (*callee)->name, (*callee)->parent_node->our_index); + 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), build_int_cst_type(SIZE_T, i), @@ -13164,11 +13608,13 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) // And put a pointer to that table into the file-static variable set aside // for it: - sprintf(ach, "..accessible_program_list_%ld", caller); + sprintf(ach, "..accessible_program_list_" HOST_SIZE_T_PRINT_DEC, + (fmt_size_t)caller); tree accessible_list_var_decl = gg_trans_unit_var_decl(ach); gg_assign( accessible_list_var_decl, gg_get_address_of(the_names_table) ); - sprintf(ach, "..accessible_program_pointers_%ld", caller); + sprintf(ach, "..accessible_program_pointers_" HOST_SIZE_T_PRINT_DEC, + (fmt_size_t)caller); tree accessible_programs_decl = gg_trans_unit_var_decl(ach); gg_assign( accessible_programs_decl, gg_get_address_of(the_constructed_table) ); } @@ -13179,72 +13625,6 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) } void -parser_set_handled(ec_type_t ec_handled) - { - if( mode_syntax_only() ) return; - SHOW_PARSE - { - SHOW_PARSE_HEADER - char ach[64]; - sprintf(ach, "ec_type_t: 0x%lx", size_t(ec_handled)); - SHOW_PARSE_TEXT(ach); - SHOW_PARSE_END - } - - TRACE1 - { - TRACE1_HEADER - TRACE1_END - } - - if( gg_trans_unit.function_stack.size() ) - { - if( ec_handled ) - { - // We assume that exception_handled is zero, always. We only make it - // non-zero when something needs to be done. __gg__match_exception is - // in charge of setting it back to zero. - gg_assign(var_decl_exception_handled, - build_int_cst_type(INT, (int)ec_handled)); - } - } - else - { - yywarn("parser_set_handled() called between programs"); - } - } - -void -parser_set_file_number(int file_number) - { - if( mode_syntax_only() ) return; - SHOW_PARSE - { - SHOW_PARSE_HEADER - char ach[32]; - sprintf(ach, "file number: %d", file_number); - SHOW_PARSE_TEXT(ach); - SHOW_PARSE_END - } - - TRACE1 - { - TRACE1_HEADER - TRACE1_END - } - - if( gg_trans_unit.function_stack.size() ) - { - gg_assign(var_decl_exception_file_number, - build_int_cst_type(INT, file_number)); - } - else - { - yywarn("parser_set_file_number() called between programs"); - } - } - -void parser_set_numeric(struct cbl_field_t *tgt, ssize_t value) { Analyze(); @@ -13255,7 +13635,7 @@ parser_set_numeric(struct cbl_field_t *tgt, ssize_t value) SHOW_PARSE_TEXT(tgt->name) SHOW_PARSE_TEXT(" to ") char ach[32]; - sprintf(ach, "%ld", value); + sprintf(ach, HOST_SIZE_T_PRINT_DEC, (fmt_size_t)value); SHOW_PARSE_TEXT(ach); SHOW_PARSE_END } @@ -13270,159 +13650,6 @@ parser_set_numeric(struct cbl_field_t *tgt, ssize_t value) NULL_TREE ); } -static void -stash_exceptions( const cbl_enabled_exceptions_array_t *enabled ) - { - // We need to create a static array of bytes - size_t narg = enabled->nbytes(); - unsigned char *p = (unsigned char *)(enabled->ecs); - - static size_t prior_narg = 0; - static size_t max_narg = 128; - static unsigned char *prior_p = (unsigned char *)xmalloc(max_narg); - - bool we_got_new_data = false; - if( prior_narg != narg ) - { - we_got_new_data = true; - } - else - { - // The narg counts are the same. - for(size_t i=0; i<narg; i++) - { - if( p[i] != prior_p[i] ) - { - we_got_new_data = true; - break; - } - } - } - - if( !we_got_new_data ) - { - return; - } - - if( narg > max_narg ) - { - max_narg = narg; - prior_p = (unsigned char *)xrealloc(prior_p, max_narg); - } - - memcpy(prior_p, p, narg); - - static int count = 1; - - tree array_of_chars_type; - tree array_of_chars; - - if( narg ) - { - char ach[32]; - sprintf(ach, "_ec_array_%d", count++); - array_of_chars_type = build_array_type_nelts(UCHAR, narg); - - // We have the array. Now we need to build the constructor for it - tree constr = make_node(CONSTRUCTOR); - TREE_TYPE(constr) = array_of_chars_type; - TREE_STATIC(constr) = 1; - TREE_CONSTANT(constr) = 1; - - for(size_t i=0; i<narg; i++) - { - CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr), - build_int_cst_type(SIZE_T, i), - build_int_cst_type(UCHAR, p[i])); - } - array_of_chars = gg_define_variable(array_of_chars_type, ach, vs_static); - DECL_INITIAL(array_of_chars) = constr; - - gg_call(VOID, - "__gg__stash_exceptions", - build_int_cst_type(SIZE_T, enabled->nec), - narg ? gg_get_address_of(array_of_chars) : null_pointer_node, - 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_prepare( const cbl_name_t statement_name, - const cbl_enabled_exceptions_array_t *enabled ) - { - Analyze(); - SHOW_PARSE - { - SHOW_PARSE_HEADER - SHOW_PARSE_TEXT(enabled->nec? " stashing " : " skipping ") - SHOW_PARSE_TEXT(statement_name) - SHOW_PARSE_END - } - - TRACE1 - { - TRACE1_HEADER - TRACE1_END - } - - if( enabled->nec ) - { - if( gg_trans_unit.function_stack.size() ) - { - stash_exceptions(enabled); - store_location_stuff(statement_name); - } - else - { - yywarn("parser_exception_prepare() called between programs"); - } - } - } - void parser_exception_clear() { @@ -13451,8 +13678,7 @@ parser_exception_raise(ec_type_t ec) } void -parser_match_exception(cbl_field_t *index, - cbl_field_t *blob ) +parser_match_exception(cbl_field_t *index) { Analyze(); SHOW_PARSE @@ -13460,14 +13686,6 @@ parser_match_exception(cbl_field_t *index, SHOW_PARSE_HEADER SHOW_PARSE_FIELD(" index ", index) SHOW_PARSE_INDENT - if( blob ) - { - SHOW_PARSE_FIELD("blob ", blob) - } - else - { - SHOW_PARSE_TEXT("blob is NULL") - } SHOW_PARSE_END } @@ -13476,22 +13694,12 @@ parser_match_exception(cbl_field_t *index, TRACE1_HEADER TRACE1_FIELD("index ", index, "") TRACE1_INDENT - TRACE1_TEXT("blob ") - if( blob ) - { - TRACE1_TEXT(blob->name) - } - else - { - TRACE1_TEXT("is NULL") - } TRACE1_END } gg_call(VOID, "__gg__match_exception", gg_get_address_of(index->var_decl_node), - blob ? blob->var_decl_node : null_pointer_node, NULL_TREE); TRACE1 @@ -13514,9 +13722,36 @@ parser_check_fatal_exception() SHOW_PARSE_TEXT(" Check for fatal EC...") SHOW_PARSE_END } - gg_call(VOID, - "__gg__check_fatal_exception", - NULL_TREE); + TRACE1 + { + TRACE1_HEADER + TRACE1_TEXT(" Check for fatal EC...") + 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 +parser_push_exception() + { + gg_call(VOID, "__gg__exception_push", NULL_TREE); + } + +void +parser_pop_exception() + { + gg_call(VOID, "__gg__exception_pop", NULL_TREE); } void @@ -13619,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("# HIJACKED DUBNER CODE START"); + gg_insert_into_assemblerf("%s HIJACKED DUBNER CODE START", ASM_COMMENT_START); for(int i=0; i<10; i++) { @@ -13632,12 +13867,12 @@ hijack_for_development(const char *funcname) NULL_TREE); } - gg_insert_into_assembler("# HIJACKED DUBNER CODE END"); + 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) ) @@ -13681,7 +13916,7 @@ mh_identical(cbl_refer_t &destref, SHOW_PARSE_TEXT("mh_identical()"); } gg_memcpy(gg_add(member(destref.field->var_decl_node, "data"), - refer_offset_dest(destref)), + refer_offset(destref)), gg_add(member(sourceref.field->var_decl_node, "data"), tsource.offset), build_int_cst_type(SIZE_T, sourceref.field->data.capacity)); @@ -13722,7 +13957,7 @@ mh_source_is_literalN(cbl_refer_t &destref, gg_call(VOID, "__gg__psz_to_alpha_move", gg_get_address_of(destref.field->var_decl_node), - refer_offset_dest(destref), + refer_offset(destref), refer_size_dest(destref), gg_string_literal(buffer), build_int_cst_type(SIZE_T, strlen(sourceref.field->data.initial)), @@ -13760,13 +13995,13 @@ mh_source_is_literalN(cbl_refer_t &destref, { // We are dealing with a negative number gg_memset(gg_add(member(destref.field->var_decl_node, "data"), - refer_offset_dest(destref)), + refer_offset(destref)), build_int_cst_type(UCHAR, 0xFF), build_int_cst_type(SIZE_T, 8)); } ELSE gg_memset(gg_add(member(destref.field->var_decl_node, "data"), - refer_offset_dest(destref)), + refer_offset(destref)), build_int_cst_type(UCHAR, 0x00), build_int_cst_type(SIZE_T, 8)); ENDIF @@ -13775,7 +14010,7 @@ mh_source_is_literalN(cbl_refer_t &destref, { // The too-short source is positive. gg_memset(gg_add(member(destref.field->var_decl_node, "data"), - refer_offset_dest(destref)), + refer_offset(destref)), build_int_cst_type(UCHAR, 0x00), build_int_cst_type(SIZE_T, 8)); } @@ -13784,7 +14019,7 @@ mh_source_is_literalN(cbl_refer_t &destref, tree literalN_value = get_literalN_value(sourceref.field); scale_by_power_of_ten_N(literalN_value, -sourceref.field->data.rdigits); gg_memcpy(gg_add(member(destref.field->var_decl_node, "data"), - refer_offset_dest(destref)), + refer_offset(destref)), gg_get_address_of(literalN_value), build_int_cst_type(SIZE_T, sourceref.field->data.capacity)); moved = true; @@ -13845,7 +14080,7 @@ mh_source_is_literalN(cbl_refer_t &destref, tree dest_location = gg_indirect( gg_cast(build_pointer_type(dest_type), gg_add(member(destref.field->var_decl_node, "data"), - refer_offset_dest(destref)))); + refer_offset(destref)))); gg_assign(dest_location, gg_cast(dest_type, source)); moved = true; break; @@ -13874,7 +14109,7 @@ mh_source_is_literalN(cbl_refer_t &destref, gg_call(INT, "__gg__int128_to_qualified_field", gg_get_address_of(destref.field->var_decl_node), - refer_offset_dest(destref), + refer_offset(destref), refer_size_dest(destref), gg_cast(INT128, literalN_value), build_int_cst_type(INT, sourceref.field->data.rdigits), @@ -13905,7 +14140,7 @@ mh_source_is_literalN(cbl_refer_t &destref, gg_call(VOID, "__gg__string_to_alpha_edited_ascii", gg_add( member(destref.field->var_decl_node, "data"), - refer_offset_dest(destref) ), + refer_offset(destref) ), gg_string_literal(sourceref.field->data.initial), build_int_cst_type(INT, strlen(sourceref.field->data.initial)), gg_string_literal(destref.field->data.picture), @@ -13917,7 +14152,7 @@ mh_source_is_literalN(cbl_refer_t &destref, case FldFloat: { tree tdest = gg_add(member(destref.field->var_decl_node, "data"), - refer_offset_dest(destref) ); + refer_offset(destref) ); switch( destref.field->data.capacity ) { // For some reason, using FLOAT128 in the build_pointer_type causes @@ -13953,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)); @@ -13982,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); @@ -14021,7 +14256,7 @@ mh_dest_is_float( cbl_refer_t &destref, gg_call(VOID, "__gg__float32_from_int128", gg_get_address_of(destref.field->var_decl_node), - refer_offset_dest(destref), + refer_offset(destref), tsource.pfield, tsource.offset, build_int_cst_type(INT, rounded), @@ -14032,7 +14267,7 @@ mh_dest_is_float( cbl_refer_t &destref, gg_call(VOID, "__gg__float64_from_int128", gg_get_address_of(destref.field->var_decl_node), - refer_offset_dest(destref), + refer_offset(destref), tsource.pfield, tsource.offset, build_int_cst_type(INT, rounded), @@ -14043,7 +14278,7 @@ mh_dest_is_float( cbl_refer_t &destref, gg_call(VOID, "__gg__float128_from_int128", gg_get_address_of(destref.field->var_decl_node), - refer_offset_dest(destref), + refer_offset(destref), tsource.pfield, tsource.offset, build_int_cst_type(INT, rounded), @@ -14085,9 +14320,9 @@ mh_dest_is_float( cbl_refer_t &destref, tree stype = float_type_of(&sourceref); tree tdest = gg_add(member(destref.field->var_decl_node, "data"), - refer_offset_dest(destref)); + refer_offset(destref)); tree source = gg_add(member(sourceref.field->var_decl_node, "data"), - refer_offset_source(sourceref)); + refer_offset(sourceref)); gg_assign(gg_indirect(gg_cast(build_pointer_type(dtype), tdest)), gg_cast(dtype, gg_indirect(gg_cast(build_pointer_type(stype), @@ -14104,7 +14339,7 @@ mh_dest_is_float( cbl_refer_t &destref, gg_call_expr( INT, "__gg__float64_from_128", gg_get_address_of(destref.field->var_decl_node), - refer_offset_dest(destref), + refer_offset(destref), tsource.pfield, tsource.offset, NULL_TREE)); @@ -14114,7 +14349,7 @@ mh_dest_is_float( cbl_refer_t &destref, gg_call( INT, "__gg__float64_from_128", gg_get_address_of(destref.field->var_decl_node), - refer_offset_dest(destref), + refer_offset(destref), tsource.pfield, tsource.offset, NULL_TREE); @@ -14131,7 +14366,7 @@ mh_dest_is_float( cbl_refer_t &destref, gg_call_expr( INT, "__gg__float32_from_64", gg_get_address_of(destref.field->var_decl_node), - refer_offset_dest(destref), + refer_offset(destref), tsource.pfield, tsource.offset, NULL_TREE)); @@ -14141,7 +14376,7 @@ mh_dest_is_float( cbl_refer_t &destref, gg_call( INT, "__gg__float32_from_64", gg_get_address_of(destref.field->var_decl_node), - refer_offset_dest(destref), + refer_offset(destref), tsource.pfield, tsource.offset, NULL_TREE); @@ -14156,7 +14391,7 @@ mh_dest_is_float( cbl_refer_t &destref, gg_call_expr( INT, "__gg__float32_from_128", gg_get_address_of(destref.field->var_decl_node), - refer_offset_dest(destref), + refer_offset(destref), tsource.pfield, tsource.offset, NULL_TREE)); @@ -14166,7 +14401,7 @@ mh_dest_is_float( cbl_refer_t &destref, gg_call( INT, "__gg__float32_from_128", gg_get_address_of(destref.field->var_decl_node), - refer_offset_dest(destref), + refer_offset(destref), tsource.pfield, tsource.offset, NULL_TREE); @@ -14189,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), @@ -14273,7 +14508,7 @@ mh_numeric_display( cbl_refer_t &destref, static tree source_p = gg_define_variable(UCHAR_P, "..mhnd_source", vs_file_static); // The source data pointer static tree source_ep = gg_define_variable(UCHAR_P, "..mhnd_source_e", vs_file_static); // When we need an end pointer - gg_assign(dest_p, qualified_data_dest(destref)); + gg_assign(dest_p, qualified_data_location(destref)); gg_assign(source_p, gg_add(member(sourceref.field, "data"), tsource.offset)); @@ -14613,7 +14848,7 @@ mh_numeric_display( cbl_refer_t &destref, if( destref.field->attr & leading_e ) { // The sign bit goes into the first byte: - gg_assign(dest_p, qualified_data_dest(destref)); + gg_assign(dest_p, qualified_data_location(destref)); } else { @@ -14775,7 +15010,7 @@ mh_little_endian( cbl_refer_t &destref, // Get binary value from float actually scales the source value to the // dest:: rdigits copy_little_endian_into_place(destref.field, - refer_offset_dest(destref), + refer_offset(destref), source, destref.field->data.rdigits, check_for_error, @@ -14789,7 +15024,7 @@ mh_little_endian( cbl_refer_t &destref, sourceref.field, tsource.offset); copy_little_endian_into_place(destref.field, - refer_offset_dest(destref), + refer_offset(destref), source, sourceref.field->data.rdigits, check_for_error, @@ -14812,13 +15047,13 @@ mh_source_is_group( cbl_refer_t &destref, // We are moving a group to a something. The rule here is just move as // many bytes as you can, and, if necessary, fill with spaces tree tdest = gg_add( member(destref.field->var_decl_node, "data"), - refer_offset_dest(destref)); + refer_offset(destref)); tree tsource = gg_add( member(sourceref.field->var_decl_node, "data"), tsrc.offset); tree dbytes = refer_size_dest(destref); tree sbytes = tsrc.length; - IF( sbytes, ge_op, dbytes ) + IF( sbytes, ge_op, gg_cast(TREE_TYPE(sbytes), dbytes) ) { // There are too many source bytes gg_memcpy(tdest, tsource, dbytes); @@ -14880,7 +15115,7 @@ move_helper(tree size_error, // This is an INT stash_size = destref.field->data.capacity; gg_assign(stash, gg_cast(UCHAR_P, gg_realloc(stash, stash_size))); } - st_data = qualified_data_dest(destref); + st_data = qualified_data_location(destref); st_size = refer_size_dest(destref); gg_memcpy(stash, st_data, @@ -15017,7 +15252,7 @@ move_helper(tree size_error, // This is an INT gg_call_expr( INT, "__gg__move_literala", gg_get_address_of(destref.field->var_decl_node), - refer_offset_dest(destref), + refer_offset(destref), refer_size_dest(destref), build_int_cst_type(INT, rounded_parameter), build_string_literal(source_length, @@ -15030,7 +15265,7 @@ move_helper(tree size_error, // This is an INT gg_call ( INT, "__gg__move_literala", gg_get_address_of(destref.field->var_decl_node), - refer_offset_dest(destref), + refer_offset(destref), refer_size_dest(destref), build_int_cst_type(INT, rounded_parameter), build_string_literal(source_length, @@ -15073,7 +15308,7 @@ move_helper(tree size_error, // This is an INT gg_call_expr( INT, "__gg__move", gg_get_address_of(destref.field->var_decl_node), - refer_offset_dest(destref), + refer_offset(destref), refer_size_dest(destref), tsource.pfield, tsource.offset, @@ -15087,7 +15322,7 @@ move_helper(tree size_error, // This is an INT gg_call ( INT, "__gg__move", gg_get_address_of(destref.field->var_decl_node), - refer_offset_dest(destref), + refer_offset(destref), refer_size_dest(destref), tsource.pfield, tsource.offset, @@ -15246,14 +15481,14 @@ binary_initial_from_float128(cbl_field_t *field, int rdigits, case 4: case 8: case 16: - type = build_nonstandard_integer_type (field->data.capacity - * BITS_PER_UNIT, 0); + type = build_nonstandard_integer_type ( field->data.capacity + * BITS_PER_UNIT, 0); native_encode_wide_int (type, i, (unsigned char *)retval, - field->data.capacity); + field->data.capacity); break; default: fprintf(stderr, - "Trouble in initial_from_float128 at %s() %s:%d\n", + "Trouble in binary_initial_from_float128 at %s() %s:%d\n", __func__, __FILE__, __LINE__); @@ -15312,13 +15547,13 @@ digits_from_float128(char *retval, cbl_field_t *field, size_t width, int rdigits } static char * -initial_from_float128(cbl_field_t *field) +initial_from_initial(cbl_field_t *field) { Analyze(); // This routine returns an xmalloced buffer that is intended to replace the // data.initial member of the incoming field. - //fprintf(stderr, "initial_from_float128 %s\n", field->name); + //fprintf(stderr, "initial_from_initial %s\n", field->name); char *retval = NULL; int rdigits; @@ -15378,8 +15613,9 @@ initial_from_float128(cbl_field_t *field) } if( set_return ) { - retval = (char *)xmalloc(field->data.capacity); + retval = (char *)xmalloc(field->data.capacity+1); memset(retval, const_char, field->data.capacity); + retval[field->data.capacity] = '\0'; return retval; } } @@ -15464,7 +15700,7 @@ initial_from_float128(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 ) ) @@ -15553,7 +15789,7 @@ initial_from_float128(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) ) @@ -15621,22 +15857,19 @@ initial_from_float128(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 @@ -15684,17 +15917,17 @@ initial_from_float128(cbl_field_t *field) case 4: value = real_value_truncate (TYPE_MODE (FLOAT), value); native_encode_real (SCALAR_FLOAT_TYPE_MODE (FLOAT), &value, - (unsigned char *)retval, 4, 0); + (unsigned char *)retval, 4, 0); break; case 8: value = real_value_truncate (TYPE_MODE (DOUBLE), value); native_encode_real (SCALAR_FLOAT_TYPE_MODE (DOUBLE), &value, - (unsigned char *)retval, 8, 0); + (unsigned char *)retval, 8, 0); break; case 16: value = real_value_truncate (TYPE_MODE (FLOAT128), value); native_encode_real (SCALAR_FLOAT_TYPE_MODE (FLOAT128), &value, - (unsigned char *)retval, 16, 0); + (unsigned char *)retval, 16, 0); break; } break; @@ -15868,38 +16101,6 @@ psa_global(cbl_field_t *new_var) sprintf(ach, "__gg__%s", mname); free(mname); - if( getenv("SHOW_GLOBAL_VARIABLES") ) - { - char ach_type[32]; - strcpy(ach_type, cbl_field_type_str(new_var->type)); - - fprintf(stderr, "struct cblc_field_t %s = {\n", ach); - fprintf(stderr, " .data = NULL ,\n" ); - fprintf(stderr, " .capacity = %d ,\n", new_var->data.capacity ); - fprintf(stderr, " .offset = %ld ,\n" , new_var->offset ); - fprintf(stderr, " .name = \"%s\" ,\n" , new_var->name ); - fprintf(stderr, " .picture = \"%s\" ,\n" , new_var->data.picture ? new_var->data.picture : "" ); - if( new_var->data.initial || new_var->type == FldPointer ) - { - fprintf(stderr, " .initial = \"%s\" ,\n" , new_var->data.picture ? new_var->data.picture : "" ); - } - else - { - fprintf(stderr, " .initial = NULL ,\n" ); - } - fprintf(stderr, " .parent = NULL,\n" ); - fprintf(stderr, " .depending_on = NULL ,\n" ); - fprintf(stderr, " .depends_on = NULL ,\n" ); - fprintf(stderr, " .occurs_lower = 0 ,\n" ); - fprintf(stderr, " .occurs_upper = 0 ,\n" ); - fprintf(stderr, " .attr = 0x%lx ,\n" , new_var->attr ); - fprintf(stderr, " .type = %s ,\n" , ach_type); - fprintf(stderr, " .level = %d ,\n" , new_var->level ); - fprintf(stderr, " .digits = %d ,\n" , new_var->data.digits ); - fprintf(stderr, " .rdigits = %d ,\n" , new_var->data.rdigits ); - fprintf(stderr, " };\n"); - } - if( strcmp(new_var->name, "_VERY_TRUE") == 0 ) { new_var->var_decl_node = boolean_true_node; @@ -16009,12 +16210,14 @@ psa_new_var_decl(cbl_field_t *new_var, const char *external_record_base) && symbol_at(new_var->parent)->type == SymField ) { // We have a parent that is a field - sprintf(id_string, ".%ld_%ld", our_index, new_var->parent); + sprintf(id_string, "." HOST_SIZE_T_PRINT_DEC "_" HOST_SIZE_T_PRINT_DEC, + (fmt_size_t)our_index, (fmt_size_t)new_var->parent); } else { // The parent is zero, so it'll be implied: - sprintf(id_string, ".%ld", our_index); + sprintf(id_string, "." HOST_SIZE_T_PRINT_DEC, + (fmt_size_t)our_index); } if(strcasecmp(new_var->name, "filler") == 0) @@ -16136,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. @@ -16156,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]; @@ -16178,14 +16397,13 @@ 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 - { - TRACE1_INDENT - TRACE1_TEXT("Finished") - TRACE1_END } +// TRACE1 +// { +// TRACE1_INDENT +// TRACE1_TEXT("Finished") +// TRACE1_END +// } } #endif @@ -16251,33 +16469,34 @@ parser_symbol_add(struct cbl_field_t *new_var ) { do { - fprintf(stderr, "( %d ) %s():", CURRENT_LINE_NUMBER, __func__); + fprintf(stderr, "( %d ) %s:", CURRENT_LINE_NUMBER, __func__); } while(0); - fprintf(stderr, " %2.2d %s<%s> off:%zd " - "msiz:%d cap:%d dig:%d rdig:%d attr:0x%lx loc:%p", + fprintf(stderr, " %2.2d %s<%s> off:" HOST_SIZE_T_PRINT_DEC " " + "msiz:%d cap:%d dig:%d rdig:%d attr:0x" HOST_SIZE_T_PRINT_HEX_PURE " loc:%p", new_var->level, new_var->name, cbl_field_type_str(new_var->type), - new_var->offset, + (fmt_size_t)new_var->offset, new_var->data.memsize, new_var->data.capacity, new_var->data.digits, new_var->data.rdigits, - new_var->attr, + (fmt_size_t)new_var->attr, (void*)new_var); if( is_table(new_var) ) { - fprintf(stderr," OCCURS:%zd", new_var->occurs.ntimes()); + 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, - " parent:(%zd)%s", - new_var->parent, + " parent:(" HOST_SIZE_T_PRINT_DEC ")%s", + (fmt_size_t)new_var->parent, parent->name); } else @@ -16286,12 +16505,12 @@ 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, - " parent_file:(%zd)%s", - new_var->parent, + " parent_file:(" HOST_SIZE_T_PRINT_DEC ")%s", + (fmt_size_t)new_var->parent, e->elem.file.name); if( e->elem.file.attr & external_e ) { @@ -16388,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 @@ -16416,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); @@ -16456,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 ) @@ -16575,24 +16791,15 @@ parser_symbol_add(struct cbl_field_t *new_var ) size_t our_index = new_var->our_index; - // During the early stages of implementing cbl_field_t::our_index, there - // were execution paths in parse.y and parser.cc that resulted in our_index - // not being set. I hereby try to use field_index() to find the index - // of this field to resolve those. I note that field_index does a linear - // search of the symbols[] table to find that index. That's why I don't - // use it routinely; it results in O(N^squared) computational complexity - // to do a linear search of the symbol table for each symbol - if( !our_index && new_var->type != FldLiteralN && !(new_var->attr & intermediate_e)) { - our_index = field_index(new_var); - if( our_index == (size_t)-1 ) - { - // Hmm. Couldn't find it. Seems odd. - our_index = 0; - } + // During the early stages of implementing cbl_field_t::our_index, there + // were execution paths in parse.y and parser.cc that resulted in + // our_index not being set. Those should be gone. + fprintf(stderr, "our_index is NULL under unanticipated circumstances"); + gcc_assert(false); } // When we create the cblc_field_t structure, we need a data pointer @@ -16601,7 +16808,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) // we calculate data as the pointer to our parent's data plus our // offset. - // declare and define the structure. This code *must* match + // Declare and define the structure. This code *must* match // the C structure declared in libgcobol.c. Towards that end, the // variables are declared in descending order of size in order to // make the packing match up. @@ -16675,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, @@ -16695,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, @@ -16745,11 +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 %ld)\n", - new_var->name, - 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 ) @@ -16782,16 +16985,16 @@ parser_symbol_add(struct cbl_field_t *new_var ) { // Avoid doubling up on leading underscore sprintf(achDataName, - "%s_data_%lu", + "%s_data_" HOST_SIZE_T_PRINT_UNSIGNED, new_var->name, - sv_data_name_counter++); + (fmt_size_t)sv_data_name_counter++); } else { sprintf(achDataName, - "_%s_data_%lu", + "_%s_data_" HOST_SIZE_T_PRINT_UNSIGNED, new_var->name, - sv_data_name_counter++); + (fmt_size_t)sv_data_name_counter++); } if( new_var->attr & external_e ) @@ -16820,7 +17023,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) if( new_var->data.initial ) { - new_initial = initial_from_float128(new_var); + new_initial = initial_from_initial(new_var); } if( new_initial ) { @@ -16840,49 +17043,15 @@ parser_symbol_add(struct cbl_field_t *new_var ) else { new_initial = new_var->data.initial; - if( !new_initial ) - { - if( length_of_initial_string ) - { - gcc_unreachable(); - } - } - else - { - if( new_var->type == FldLiteralN ) - { - // We need to convert this string to the internal character set - // char *buffer = NULL; - // size_t buffer_size = 0; - // raw_to_internal(&buffer, - // &buffer_size, - // new_var->data.initial, - // strlen(new_var->data.initial)); - // new_initial = bufer; - // length_of_initial_string = strlen(new_var->data.initial)+1; - } - } } actual_allocate: - // if( level_88_string ) - // { - // actually_create_the_static_field( new_var, - // data_area, - // level_88_string_size, - // level_88_string, - // immediate_parent, - // new_var_decl); - // } - // else - { - actually_create_the_static_field( new_var, - data_area, - length_of_initial_string, - new_initial, - immediate_parent, - new_var_decl); - } + actually_create_the_static_field( new_var, + data_area, + length_of_initial_string, + new_initial, + immediate_parent, + new_var_decl); if( level_88_string ) { diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h index 447b62e..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, @@ -518,13 +515,7 @@ void parser_return_atend( cbl_file_t *file ); void parser_return_notatend( cbl_file_t *file ); void parser_return_finish( cbl_file_t *file ); -void parser_exception_prepare( const cbl_name_t statement_name, - const cbl_enabled_exceptions_array_t *enabled ); - -//void parser_exception_condition( cbl_field_t *ec ); - struct cbl_exception_file; -struct cbl_exception_files_t; void parser_exception_raise(ec_type_t ec); @@ -533,10 +524,11 @@ void parser_call_exception_end( cbl_label_t *name ); //void parser_stash_exceptions(const cbl_enabled_exceptions_array_t *enabled); -void parser_match_exception(cbl_field_t *index, - cbl_field_t *blob); +void parser_match_exception(cbl_field_t *index); void parser_check_fatal_exception(); void parser_clear_exception(); +void parser_push_exception(); +void parser_pop_exception(); void parser_call_targets_dump(); size_t parser_call_target_update( size_t caller, @@ -557,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); @@ -569,8 +561,6 @@ void parser_print_long(const char *fmt, long N); // fmt needs to have a %ls in i void parser_print_string(const char *ach); void parser_print_string(const char *fmt, const char *ach); // fmt needs to have a %s in it void parser_set_statement(const char *statement); -void parser_set_handled(ec_type_t ec_handled); -void parser_set_file_number(int file_number); void parser_exception_clear(); void parser_init_list_size(int count_of_variables); @@ -579,6 +569,9 @@ void parser_init_list(); tree file_static_variable(tree type, const char *name); -void parser_statement_begin(); +void parser_statement_begin( const cbl_name_t name, tree ecs, tree dcls ); + +tree parser_compile_ecs( const std::vector<uint64_t>& ecs ); +tree parser_compile_dcls( const std::vector<uint64_t>& dcls ); #endif diff --git a/gcc/cobol/gengen.cc b/gcc/cobol/gengen.cc index f182f7f..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: @@ -393,23 +395,20 @@ show_type(tree type) case REAL_TYPE: sprintf(ach, - "%3ld-bit REAL", + "%3" PRId64 "-bit REAL", TREE_INT_CST_LOW(TYPE_SIZE(type))); break; case INTEGER_TYPE: sprintf(ach, - "%3ld-bit %s INT", + "%3" PRId64 "-bit %s INT", TREE_INT_CST_LOW(TYPE_SIZE(type)), (TYPE_UNSIGNED(type) ? "unsigned" : " signed")); 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(); @@ -892,7 +896,8 @@ gg_unique_in_function(const char *var_name, gg_variable_scope_t vs_scope) char *retval = (char *)xmalloc(strlen(var_name)+32); if( (vs_scope == vs_stack || vs_scope == vs_static) ) { - sprintf(retval, "%s.%ld", var_name, current_function->program_id_number); + sprintf(retval, "%s." HOST_SIZE_T_PRINT_DEC, var_name, + (fmt_size_t)current_function->program_id_number); } else { @@ -932,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 @@ -2151,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; @@ -2172,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(); } @@ -2181,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(); } @@ -2196,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(), @@ -2205,8 +2195,6 @@ gg_printf(const char *format_string, ...) nargs, args); gg_append_statement(stmt); - - gg_pop_context(); } tree @@ -2232,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(); } @@ -2485,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); @@ -2614,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(); } @@ -2628,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" @@ -2717,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); } @@ -2756,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. @@ -2767,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 @@ -2798,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(); } @@ -2812,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(); } @@ -2888,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. @@ -3083,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(); } @@ -3140,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(); } @@ -3178,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[]] @@ -3195,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 @@ -3437,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 @@ -3457,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 9725754..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; @@ -413,7 +410,7 @@ fast_add( size_t nC, cbl_num_result_t *C, get_binary_value( sum, NULL, A[0].field, - refer_offset_source(A[0])); + refer_offset(A[0])); // Add in the rest of them: for(size_t i=1; i<nA; i++) @@ -421,7 +418,7 @@ fast_add( size_t nC, cbl_num_result_t *C, get_binary_value( addend, NULL, A[i].field, - refer_offset_source(A[i])); + refer_offset(A[i])); gg_assign(sum, gg_add(sum, addend)); } //gg_printf("The intermediate sum is %ld\n", gg_cast(LONG, sum), NULL_TREE); @@ -431,7 +428,7 @@ fast_add( size_t nC, cbl_num_result_t *C, { tree dest_type = tree_type_from_size(C[i].refer.field->data.capacity, 0); tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, "data"), - refer_offset_dest(C[i].refer)); + refer_offset(C[i].refer)); tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr); if( format == giving_e ) { @@ -495,12 +492,12 @@ fast_subtract(size_t nC, cbl_num_result_t *C, tree sum = gg_define_variable(term_type); tree addend = gg_define_variable(term_type); - get_binary_value(sum, NULL, A[0].field, refer_offset_dest(A[0])); + get_binary_value(sum, NULL, A[0].field, refer_offset(A[0])); // Add in the rest of them: for(size_t i=1; i<nA; i++) { - get_binary_value(sum, NULL, A[i].field, refer_offset_dest(A[i])); + get_binary_value(sum, NULL, A[i].field, refer_offset(A[i])); gg_assign(sum, gg_add(sum, addend)); } //gg_printf("The intermediate sum is %ld\n", gg_cast(LONG, sum), NULL_TREE); @@ -508,7 +505,7 @@ fast_subtract(size_t nC, cbl_num_result_t *C, if( format == giving_e ) { // We now subtract the sum from B[0] - get_binary_value(addend, NULL, B[0].field, refer_offset_dest(B[0])); + get_binary_value(addend, NULL, B[0].field, refer_offset(B[0])); gg_assign(sum, gg_subtract(addend, sum)); } @@ -517,7 +514,7 @@ fast_subtract(size_t nC, cbl_num_result_t *C, { tree dest_type = tree_type_from_size(C[i].refer.field->data.capacity, 0); tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, "data"), - refer_offset_dest(C[i].refer)); + refer_offset(C[i].refer)); tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr); if( format == giving_e ) { @@ -575,16 +572,12 @@ fast_multiply(size_t nC, cbl_num_result_t *C, tree valA = gg_define_variable(term_type); tree valB = gg_define_variable(term_type); - get_binary_value(valA, NULL, A[0].field, refer_offset_dest(A[0])); + get_binary_value(valA, NULL, A[0].field, refer_offset(A[0])); if( nB ) { // This is a MULTIPLY Format 2 - get_binary_value(valB, NULL, B[0].field, refer_offset_dest(B[0])); - } - - if(nB) - { + get_binary_value(valB, NULL, B[0].field, refer_offset(B[0])); gg_assign(valA, gg_multiply(valA, valB)); } @@ -593,7 +586,7 @@ fast_multiply(size_t nC, cbl_num_result_t *C, { tree dest_type = tree_type_from_size(C[i].refer.field->data.capacity, 0); tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, "data"), - refer_offset_dest(C[i].refer)); + refer_offset(C[i].refer)); tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr); if( nB ) { @@ -653,13 +646,13 @@ fast_divide(size_t nC, cbl_num_result_t *C, tree divisor = gg_define_variable(term_type); tree dividend = gg_define_variable(term_type); tree quotient = NULL_TREE; - get_binary_value(divisor, NULL, A[0].field, refer_offset_dest(A[0])); + get_binary_value(divisor, NULL, A[0].field, refer_offset(A[0])); if( nB ) { // This is a MULTIPLY Format 2, where we are dividing A into B and // assigning that to C - get_binary_value(dividend, NULL, B[0].field, refer_offset_dest(B[0])); + get_binary_value(dividend, NULL, B[0].field, refer_offset(B[0])); quotient = gg_define_variable(term_type); // Yes, in this case the divisor and dividend are switched. Things are @@ -672,7 +665,7 @@ fast_divide(size_t nC, cbl_num_result_t *C, { tree dest_type = tree_type_from_size(C[i].refer.field->data.capacity, 0); tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, "data"), - refer_offset_dest(C[i].refer)); + refer_offset(C[i].refer)); tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr); if( nB ) { @@ -696,7 +689,7 @@ fast_divide(size_t nC, cbl_num_result_t *C, if( remainder.field ) { tree dest_addr = gg_add(member(remainder.field->var_decl_node, "data"), - refer_offset_dest(remainder)); + refer_offset(remainder)); dest_type = tree_type_from_size(remainder.field->data.capacity, 0); ptr = gg_cast(build_pointer_type(dest_type), dest_addr); @@ -725,7 +718,7 @@ parser_add( size_t nC, cbl_num_result_t *C, SHOW_PARSE { SHOW_PARSE_HEADER - fprintf(stderr, " A[%ld]:", nA); + fprintf(stderr, " A[" HOST_SIZE_T_PRINT_DEC "]:", (fmt_size_t)nA); for(size_t i=0; i<nA; i++) { if(i > 0) @@ -737,7 +730,7 @@ parser_add( size_t nC, cbl_num_result_t *C, fprintf(stderr, "%s", format==giving_e? " GIVING" : ""); - fprintf(stderr, " C[%ld]:", nC); + fprintf(stderr, " C[" HOST_SIZE_T_PRINT_DEC "]:", (fmt_size_t)nC); for(size_t i=0; i<nC; i++) { if(i > 0) @@ -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; } } @@ -1412,7 +1406,7 @@ parser_subtract(size_t nC, cbl_num_result_t *C, // C = B - A SHOW_PARSE { SHOW_PARSE_HEADER - fprintf(stderr, " A[%ld]:", nA); + fprintf(stderr, " A[" HOST_SIZE_T_PRINT_DEC "]:", (fmt_size_t)nA); for(size_t i=0; i<nA; i++) { if(i > 0) @@ -1422,7 +1416,7 @@ parser_subtract(size_t nC, cbl_num_result_t *C, // C = B - A fprintf(stderr, "%s", A[i].field->name); } - fprintf(stderr, " B[%ld]:", nB); + fprintf(stderr, " B[" HOST_SIZE_T_PRINT_DEC "]:", (fmt_size_t)nB); for(size_t i=0; i<nB; i++) { if(i > 0) @@ -1432,7 +1426,7 @@ parser_subtract(size_t nC, cbl_num_result_t *C, // C = B - A fprintf(stderr, "%s", B[i].field->name); } - fprintf(stderr, " C[%ld]:", nC); + fprintf(stderr, " C[" HOST_SIZE_T_PRINT_DEC "]:", (fmt_size_t)nC); for(size_t i=0; i<nC; i++) { if(i > 0) @@ -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 d11e464..1d921a3 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -54,13 +54,9 @@ bool skip_exception_processing = true; bool suppress_dest_depends = false; -#define SET_EXCEPTION_CODE(a) do{set_exception_code((a));}while(0); - std::vector<std::string>current_filename; tree var_decl_exception_code; // int __gg__exception_code; -tree var_decl_exception_handled; // int __gg__exception_handled; -tree var_decl_exception_file_number; // int __gg__exception_file_number; tree var_decl_exception_file_status; // int __gg__exception_file_status; tree var_decl_exception_file_name; // const char *__gg__exception_file_name; tree var_decl_exception_statement; // const char *__gg__exception_statement; @@ -72,7 +68,6 @@ tree var_decl_exception_paragraph; // const char *__gg__exception_paragraph; tree var_decl_default_compute_error; // int __gg__default_compute_error; tree var_decl_rdigits; // int __gg__rdigits; -tree var_decl_odo_violation; // int __gg__odo_violation; tree var_decl_unique_prog_id; // size_t __gg__unique_prog_id; tree var_decl_entry_location; // This is for managing ENTRY statements @@ -111,6 +106,18 @@ tree var_decl_treeplet_4s; // SIZE_T_P , "__gg__treeplet_4s" tree var_decl_nop; // int __gg__nop; tree var_decl_main_called; // int __gg__main_called; +#if 0 +#define REFER(a) +#else +#define REFER(a) do \ + { \ + if( getenv("REFER") ) \ + { \ + fprintf(stderr, "REFER %s %s\n", __func__, a); \ + } \ + }while(0); +#endif + int get_scaled_rdigits(cbl_field_t *field) { @@ -225,11 +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 && 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 @@ -266,166 +279,156 @@ get_integer_value(tree value, gg_assign(value, gg_cast(TREE_TYPE(value), temp)); } -static tree -get_data_offset_dest(cbl_refer_t &refer, - int *pflags = NULL) +static +tree // This is a SIZE_T +get_any_capacity(cbl_field_t *field) { - Analyze(); - // This routine returns a tree which is the size_t offset to the data in the - // refer/field - - // Because this is for destination/receiving variables, OCCURS DEPENDING ON - // is not checked. + if( field->attr & (any_length_e | intermediate_e) ) + { + return member(field->var_decl_node, "capacity"); + } + else + { + return build_int_cst_type(SIZE_T, field->data.capacity); + } + } - tree retval = gg_define_variable(SIZE_T); - gg_assign(retval, size_t_zero_node); +/* 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. - // We have a refer. - // At the very least, we have an constant offset - int all_flags = 0; - int all_flag_bit = 1; + 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." - static tree value64 = gg_define_variable(LONG, ".._gdod_value64", vs_file_static); + get_integer_value(refstart, + refer.refmod.from->field, + refer_offset(*refer.refmod.from)); + gg_decrement(refstart); - if( refer.nsubscript ) - { - // We have at least one subscript: + 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; + } - // Figure we have three subscripts, so nsubscript is 3 - // Figure that the subscripts are {5, 4, 3} + // ec_bound_ref_mode_e checking is enabled: - // We expect that starting from refer.field, that three of our ancestors -- - // call them A1, A2, and A3 -- have occurs clauses. + get_integer_value(refstart, + refer.refmod.from->field, + refer_offset(*refer.refmod.from), + CHECK_FOR_FRACTIONAL_DIGITS); - // We need to start with the rightmost subscript, and work our way up through - // our parents. As we find each parent with an OCCURS, we increment qual_data - // by (subscript-1)*An->data.capacity + 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 - // Establish the field_t pointer for walking up through our ancestors: - cbl_field_t *parent = refer.field; + // Make refstart zero-based: + gg_decrement(refstart); - // Note the backwards test, because refer->nsubscript is an unsigned value - for(size_t i=refer.nsubscript-1; i<refer.nsubscript; i-- ) + 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)) ) { - // We need to search upward for an ancestor with occurs_max: - while(parent) - { - if( parent->occurs.ntimes() ) - { - break; - } - parent = parent_of(parent); - } - // we might have an error condition at this point: - if( !parent ) - { - cbl_internal_error("Too many subscripts"); - } - // Pick up the integer value of the subscript: - static tree subscript = gg_define_variable(LONG, "..gdod_subscript", vs_file_static); - - if( process_this_exception(ec_bound_subscript_e) ) + // 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(value64, - refer.subscripts[i].field, - refer_offset_dest(refer.subscripts[i]), + 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 ) { - if( enabled_exceptions.match(ec_bound_subscript_e) ) - { - // The subscript isn't an integer - SET_EXCEPTION_CODE(ec_bound_subscript_e); - gg_assign(subscript, gg_cast(TREE_TYPE(subscript), integer_zero_node)); - } - else - { - rt_error("error: a table subscript is not an integer"); - } - } - ELSE - { - gg_assign(subscript, gg_cast(TREE_TYPE(subscript), value64)); - } - ENDIF - } - else - { - get_integer_value(subscript, - refer.subscripts[i].field, - refer_offset_dest(refer.subscripts[i])); - } - - // 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 - // This is our internal representation for ALL, as in TABLE(ALL) - - // Set the subscript to 1 - gg_assign(subscript, - build_int_cst_type( TREE_TYPE(subscript), 1)); - // 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); - if( process_this_exception(ec_bound_subscript_e) ) - { - // 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, gg_cast(TREE_TYPE(subscript), 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 { - // 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()) ) + // The length is an integer, so we can keep going. + IF( reflen, lt_op, gg_cast(LONG, integer_one_node) ) { - // The subscript is too large - if( enabled_exceptions.match(ec_bound_subscript_e) ) - { - SET_EXCEPTION_CODE(ec_bound_subscript_e); - gg_assign(subscript, gg_cast(TREE_TYPE(subscript), integer_zero_node)); - } - else - { - rt_error("error: table subscript is too large"); - } + // 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 { - // We have a good subscript: - // Check for an ODO violation: - if( parent->occurs.depending_on ) + IF( gg_add(refstart, reflen), + gt_op, + gg_cast(TREE_TYPE(refstart), get_any_capacity(refer.field)) ) { - 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 ) - { - gg_assign(var_decl_odo_violation, integer_one_node); - } - ELSE - ENDIF + // 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)); } - - tree augment = gg_multiply(subscript, build_int_cst_type(INT, parent->data.capacity)); - gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment))); + ELSE + { + // There are no problems, so there is no error condition, and + // refstart and reflen are correct. + } + ENDIF } ENDIF } @@ -433,120 +436,103 @@ get_data_offset_dest(cbl_refer_t &refer, } else { - // Assume a good subscript: - // Check for an ODO violation: - if( parent->occurs.depending_on ) - { - 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 ) - { - gg_assign(var_decl_odo_violation, integer_one_node); - } - ELSE - ENDIF - } - tree augment = gg_multiply(subscript, build_int_cst_type(INT, parent->data.capacity)); - gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment))); + // There is no refmod length, so we default to the remaining characters + gg_assign(reflen, gg_subtract(get_any_capacity(refer.field), + refstart)); } - parent = parent_of(parent); } + ENDIF } + ENDIF + } - if( refer.refmod.from ) - { - // We have a refmod to deal with - static tree refstart = gg_define_variable(LONG, "..gdos_refstart", vs_file_static); - - if( process_this_exception(ec_bound_ref_mod_e) ) - { - get_integer_value(value64, - refer.refmod.from->field, - refer_offset_source(*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 - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_one_node)); - } - else - { - rt_error("error: a refmod FROM is not an integer"); - } - } - ELSE - gg_assign(refstart, value64); - ENDIF - } - else - { - get_integer_value(value64, - refer.refmod.from->field, - refer_offset_source(*refer.refmod.from) - ); - gg_assign(refstart, value64); - } +void +get_depending_on_value_from_odo(tree retval, cbl_field_t *odo) + { + /* This routine, called only when we know there is an OCCURS DEPENDING ON + clause, returns the current value of the DEPENDING ON variable. When + ec_bound_odo_e is turned on, and there is any kind of ec-bound-odo + error condition, the value returned is occurs.bounds.lower. + + This should ensure that there is no memory violation in the event of a + declarative with a RESUME NEXT STATEMENT, or before the default_condition + processing can do a controlled exit. + */ + cbl_field_t *depending_on; + depending_on = cbl_field_of(symbol_at(odo->occurs.depending_on)); - // Make refstart zero-based: - gg_decrement(refstart); + if( !enabled_exceptions.match(ec_bound_odo_e) ) + { + // With no exception testing, just pick up the value. If there is a + // the programmer will simply have to live with the consequences. + get_integer_value(retval, + depending_on, + NULL); + return; + } - if( process_this_exception(ec_bound_ref_mod_e) ) - { - IF( refstart, lt_op, gg_cast(LONG, integer_zero_node) ) - { - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_zero_node)); - } - else - { - rt_error("error: refmod FROM is less than one"); - } - } - ELSE - { - IF( refstart, gt_op, build_int_cst_type(LONG, refer.field->data.capacity) ) - { - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_zero_node)); - } - else - { - rt_error("error: refmod FROM is too large"); - } - } - ELSE - ENDIF - } - ENDIF - } + // 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); - // We have a good refstart - gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, refstart))); + 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( pflags ) + IF( retval, gt_op, build_int_cst_type(TREE_TYPE(retval), odo->occurs.bounds.upper) ) { - *pflags = all_flags; + 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 + } -// gg_printf("*****>>>>> %s(): returning %p\n", -// gg_string_literal(__func__), -// retval, -// NULL_TREE); - return retval; +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_source(cbl_refer_t &refer, +static +tree +get_data_offset(cbl_refer_t &refer, int *pflags = NULL) { Analyze(); @@ -564,10 +550,9 @@ get_data_offset_source(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 @@ -584,7 +569,7 @@ get_data_offset_source(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) @@ -601,49 +586,8 @@ get_data_offset_source(cbl_refer_t &refer, cbl_internal_error("Too many subscripts"); } // Pick up the integer value of the subscript: -// static tree subscript = gg_define_variable(LONG, "..gdos_subscript", vs_file_static); tree subscript = gg_define_variable(LONG); - if( process_this_exception(ec_bound_subscript_e) ) - { - get_integer_value(value64, - refer.subscripts[i].field, - refer_offset_source(refer.subscripts[i]), - CHECK_FOR_FRACTIONAL_DIGITS); - IF( var_decl_rdigits, - ne_op, - integer_zero_node ) - { - if( enabled_exceptions.match(ec_bound_subscript_e) ) - { - // The subscript isn't an integer - SET_EXCEPTION_CODE(ec_bound_subscript_e); - gg_assign(subscript, gg_cast(TREE_TYPE(subscript), integer_zero_node)); - } - else - { - rt_error("error: a table subscript is not an integer"); - } - } - ELSE - { - gg_assign(subscript, gg_cast(TREE_TYPE(subscript), value64)); - } - ENDIF - } - else - { - get_integer_value(subscript, - refer.subscripts[i].field, - refer_offset_source(refer.subscripts[i])); - } - - // 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 @@ -655,161 +599,94 @@ get_data_offset_source(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); - if( process_this_exception(ec_bound_subscript_e) ) + else { - // gg_printf("process_this_exception is true\n", NULL_TREE); - IF( subscript, lt_op, gg_cast(TREE_TYPE(subscript), integer_zero_node) ) + if( !enabled_exceptions.match(ec_bound_subscript_e) ) { - // The subscript is too small - SET_EXCEPTION_CODE(ec_bound_subscript_e); - gg_assign(subscript, gg_cast(TREE_TYPE(subscript), integer_zero_node)); + // With no exception testing, just pick up the value + get_integer_value(subscript, + refer.subscripts[i].field, + refer_offset(refer.subscripts[i])); } - 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()) ) + 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 is too large - if( enabled_exceptions.match(ec_bound_subscript_e) ) - { - SET_EXCEPTION_CODE(ec_bound_subscript_e); - gg_assign(subscript, gg_cast(TREE_TYPE(subscript), integer_zero_node)); - } - else - { - rt_error("error: table subscript is too large"); - } + // 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 { - // We have a good subscript: - // Check for an ODO violation: - if( parent->occurs.depending_on ) + IF( subscript, lt_op, gg_cast(TREE_TYPE(subscript), integer_one_node) ) { - 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 ) + // 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()) ) { - gg_assign(var_decl_odo_violation, integer_one_node); + // 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 } - - tree augment = gg_multiply(subscript, build_int_cst_type(INT, parent->data.capacity)); - gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment))); + ENDIF } - ENDIF - } ENDIF + } } - else + + 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) ) { - // Assume a good subscript: - // Check for an ODO violation: if( parent->occurs.depending_on ) { - 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 ) - { - gg_assign(var_decl_odo_violation, integer_one_node); - } - ELSE - ENDIF + 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); } - tree augment = gg_multiply(subscript, build_int_cst_type(INT, parent->data.capacity)); - gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, augment))); } + + // 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); - if( process_this_exception(ec_bound_ref_mod_e) ) - { - get_integer_value(value64, - refer.refmod.from->field, - refer_offset_source(*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 - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_one_node)); - } - else - { - rt_error("error: a refmod FROM is not an integer"); - } - } - ELSE - gg_assign(refstart, value64); - ENDIF - } - else - { - get_integer_value(value64, - refer.refmod.from->field, - refer_offset_source(*refer.refmod.from) - ); - gg_assign(refstart, value64); - } - - // Make refstart zero-based: - gg_decrement(refstart); - - if( process_this_exception(ec_bound_ref_mod_e) ) - { - IF( refstart, lt_op, gg_cast(LONG, integer_zero_node) ) - { - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_zero_node)); - } - else - { - rt_error("error: refmod FROM is less than one"); - } - } - ELSE - { - IF( refstart, gt_op, build_int_cst_type(LONG, refer.field->data.capacity) ) - { - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_zero_node)); - } - else - { - rt_error("error: refmod FROM is too large"); - } - } - ELSE - ENDIF - } - ENDIF - } - - // We have a good refstart gg_assign(retval, gg_add(retval, gg_cast(SIZE_T, refstart))); } @@ -818,14 +695,11 @@ get_data_offset_source(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, @@ -863,7 +737,7 @@ get_binary_value( tree value, { if( SCALAR_FLOAT_TYPE_P(value) ) { - gg_assign(value, gg_cast(TREE_TYPE(value), field->literal_decl_node)); + cbl_internal_error("cannot get %<float%> value from %s", field->name); } else { @@ -933,7 +807,7 @@ get_binary_value( tree value, // This is the we-are-done pointer gg_assign(pend, gg_add( pointer, - build_int_cst_type(SIZE_T, field->data.capacity))); + get_any_capacity(field))); static tree signbyte = gg_define_variable(UCHAR, "..gbv_signbyte", vs_file_static); @@ -1393,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); @@ -1484,17 +1358,9 @@ scale_by_power_of_ten_N(tree value, Analyzer.Message("takes int N"); if( N == 0 ) { - if( check_for_fractional ) - { - gg_assign(var_decl_rdigits, integer_zero_node); - } } else if( N > 0 ) { - if( check_for_fractional ) - { - gg_assign(var_decl_rdigits, integer_zero_node); - } tree value_type = TREE_TYPE(value); FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten(N); gg_assign(value, gg_multiply(value, wide_int_to_tree( value_type, @@ -1514,7 +1380,6 @@ scale_by_power_of_ten_N(tree value, gg_assign(var_decl_rdigits, integer_one_node); } ELSE - gg_assign(var_decl_rdigits, integer_zero_node); ENDIF } gg_assign(value, gg_divide(value, wide_int_to_tree( value_type, @@ -1696,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 ) { @@ -1714,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 ) { @@ -1740,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; @@ -1911,7 +1776,7 @@ build_array_of_treeplets( int ngroup, refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node) : gg_cast(cblc_field_p_type_node, null_pointer_node)); gg_assign(gg_array_value(var_decl_treeplet_1o, i), - refer_offset_source(refers[i])); + refer_offset(refers[i])); gg_assign(gg_array_value(var_decl_treeplet_1s, i), refer_size_source(refers[i])); } @@ -1923,7 +1788,7 @@ build_array_of_treeplets( int ngroup, refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node) : gg_cast(cblc_field_p_type_node, null_pointer_node)); gg_assign(gg_array_value(var_decl_treeplet_2o, i), - refer_offset_source(refers[i])); + refer_offset(refers[i])); gg_assign(gg_array_value(var_decl_treeplet_2s, i), refer_size_source(refers[i])); } @@ -1935,7 +1800,7 @@ build_array_of_treeplets( int ngroup, refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node) : gg_cast(cblc_field_p_type_node, null_pointer_node)); gg_assign(gg_array_value(var_decl_treeplet_3o, i), - refer_offset_source(refers[i])); + refer_offset(refers[i])); gg_assign(gg_array_value(var_decl_treeplet_3s, i), refer_size_source(refers[i])); } @@ -1947,7 +1812,7 @@ build_array_of_treeplets( int ngroup, refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node) : gg_cast(cblc_field_p_type_node, null_pointer_node)); gg_assign(gg_array_value(var_decl_treeplet_4o, i), - refer_offset_source(refers[i])); + refer_offset(refers[i])); gg_assign(gg_array_value(var_decl_treeplet_4s, i), refer_size_source(refers[i])); } @@ -1992,7 +1857,7 @@ build_array_of_fourplets( int ngroup, gg_assign(gg_array_value(var_decl_treeplet_1f, i), gg_get_address_of(refers[i].field->var_decl_node)); gg_assign(gg_array_value(var_decl_treeplet_1o, i), - refer_offset_source(refers[i], &flag_bits)); + refer_offset(refers[i], &flag_bits)); gg_assign(gg_array_value(var_decl_treeplet_1s, i), refer_size_source(refers[i])); gg_assign(gg_array_value(var_decl_fourplet_flags, i), @@ -2049,370 +1914,77 @@ char * get_literal_string(cbl_field_t *field) { assert(field->type == FldLiteralA); - char *buffer = NULL; - size_t buffer_length = 0; - if( buffer_length < field->data.capacity+1 ) - { - buffer_length = field->data.capacity+1; - buffer = (char *)xrealloc(buffer, buffer_length); - } + size_t buffer_length = field->data.capacity+1; + char *buffer = static_cast<char *>(xcalloc(1, buffer_length)); + for(size_t i=0; i<field->data.capacity; i++) { buffer[i] = ascii_to_internal(field->data.initial[i]); } - buffer[field->data.capacity] = '\0'; + return buffer; } bool refer_is_clean(cbl_refer_t &refer) { - if( !refer.field ) + if( !refer.field || refer.field->type == FldLiteralN ) { // It is routine for a refer to have no field. It happens when the parser - // passes us a refer for an optional parameter that has been ommitted, for + // 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; } return !refer.all && !refer.addr_of - && !refer.nsubscript + && !refer.nsubscript() && !refer.refmod.from && !refer.refmod.len && !refer_has_depends(refer, refer_source) ; } -void -REFER_CHECK(const char *func, - int line, - cbl_refer_t &refer - ) - { - static int counter=1; - - if( counter == 5 ) - { - fprintf(stderr, "DING! %d\n", counter); - } - - - fprintf(stderr, - "ct REFER_CHECK(%d): %s():%d %s\n", - counter, - func, - line, - refer.field->name); - gg_printf("rt REFER_CHECK(%d): %s():%d %s (%s)\n", - build_int_cst_type(INT, counter), - gg_string_literal(func), - build_int_cst_type(INT, line), - gg_string_literal(refer.field->name), - gg_string_literal(cbl_field_type_str(refer.field->type)), - NULL_TREE); - counter+=1; - } +/* 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) { Analyze(); - if( refer.refmod.from || refer.refmod.len ) - { - // First, check for compile-time errors - bool any_length = !!(refer.field->attr & any_length_e); - tree rt_capacity; - static tree value64 = gg_define_variable(LONG, "..rrl_value64", vs_file_static); - static tree refstart = gg_define_variable(LONG, "..rrl_refstart", vs_file_static); - static tree reflen = gg_define_variable(LONG, "..rrl_reflen", vs_file_static); - - if( any_length ) - { - rt_capacity = - gg_cast(LONG, - member(refer.field->var_decl_node, "capacity")); - } - else - { - rt_capacity = - build_int_cst_type(LONG, refer.field->data.capacity); - } - - gg_assign(reflen, gg_cast(TREE_TYPE(reflen), integer_one_node)); - - if( process_this_exception(ec_bound_ref_mod_e) ) - { - get_integer_value(value64, - refer.refmod.from->field, - refer_offset_source(*refer.refmod.from), - CHECK_FOR_FRACTIONAL_DIGITS); - IF( var_decl_rdigits, - ne_op, - integer_zero_node ) - { - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_one_node)); - } - else - { - rt_error("a refmod FROM value is not an integer"); - } - } - ELSE - gg_assign(refstart, value64); - ENDIF - } - else - { - get_integer_value(value64, - refer.refmod.from->field, - refer_offset_source(*refer.refmod.from) - ); - gg_assign(refstart, value64); - } - - // Make refstart zero-based: - gg_decrement(refstart); + REFER("refstart and reflen"); + static tree refstart = gg_define_variable(LONG, "..rrl_refstart", vs_file_static); + static tree reflen = gg_define_variable(LONG, "..rrl_reflen", vs_file_static); - if( process_this_exception(ec_bound_ref_mod_e) ) - { - IF( refstart, lt_op, build_int_cst_type(LONG, 0 ) ) - { - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_zero_node)); - } - else - { - rt_error("a refmod FROM value is less than zero"); - } - } - ELSE - { - IF( refstart, gt_op, rt_capacity ) - { - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(refstart, gg_cast(LONG, integer_zero_node)); - } - else - { - rt_error("a refmod FROM value is too large"); - } - } - ELSE - { - if( refer.refmod.len ) - { - get_integer_value(value64, - refer.refmod.len->field, - refer_offset_source(*refer.refmod.len), - CHECK_FOR_FRACTIONAL_DIGITS); - IF( var_decl_rdigits, - ne_op, - integer_zero_node ) - { - // length is not an integer - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(reflen, gg_cast(LONG, integer_one_node)); - } - else - { - rt_error("a refmod LENGTH is not an integer"); - } - } - ELSE - { - gg_assign(reflen, gg_cast(LONG, value64)); - } - ENDIF + get_and_check_refstart_and_reflen( refstart, reflen, refer); - IF( reflen, lt_op, gg_cast(LONG, integer_one_node) ) - { - // length is too small - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - SET_EXCEPTION_CODE(ec_bound_ref_mod_e); - gg_assign(reflen, gg_cast(LONG, integer_one_node)); - } - else - { - rt_error("a refmod LENGTH is less than one"); - } - } - ELSE - { - IF( gg_add(refstart, reflen), - gt_op, - rt_capacity ) - { - // Start + Length is too large - if( enabled_exceptions.match(ec_bound_ref_mod_e) ) - { - 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_source 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_source 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 - { - rt_error("refmod START + LENGTH is too large"); - } - } - 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 - } - else - { - if( refer.refmod.len ) - { - get_integer_value(value64, - refer.refmod.len->field, - refer_offset_source(*refer.refmod.len) - ); - gg_assign(reflen, gg_cast(LONG, value64)); - } - else - { - // There is no refmod length, so we default to the remaining characters - gg_assign(reflen, gg_subtract(rt_capacity, - refstart)); - } - } + // Arrive here with a valid value for reflen: - // 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(""); // 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); - if( process_this_exception(ec_bound_odo_e) ) - { - 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 - if( enabled_exceptions.match(ec_bound_odo_e) ) - { - SET_EXCEPTION_CODE(ec_bound_odo_e); - gg_assign(value64, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.upper)); - } - else - { - rt_error("DEPENDING ON is not an integer"); - } - } - ELSE - ENDIF - } - else - { - get_integer_value(value64, depending_on); - } - if( process_this_exception(ec_bound_odo_e) ) - { - 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) ) - { - if( enabled_exceptions.match(ec_bound_odo_e) ) - { - SET_EXCEPTION_CODE(ec_bound_odo_e); - gg_assign(value64, build_int_cst_type(TREE_TYPE(value64), odo->occurs.bounds.lower)); - } - else - { - rt_error("DEPENDING ON is less than OCCURS lower limit"); - } - } - ELSE - ENDIF - IF( value64, lt_op, gg_cast(TREE_TYPE(value64), integer_zero_node) ) - { - if( enabled_exceptions.match(ec_bound_odo_e) ) - { - SET_EXCEPTION_CODE(ec_bound_odo_e); - gg_assign(value64, gg_cast(TREE_TYPE(value64), integer_zero_node)); - } - else - { - rt_error("DEPENDING ON is greater than OCCURS upper limit"); - } - } - 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 @@ -2428,90 +2000,59 @@ refer_fill_depends(cbl_refer_t &refer) } tree // size_t -refer_offset_dest(cbl_refer_t &refer) +refer_offset(cbl_refer_t &refer, + int *pflags) { - Analyze(); - // This has to be on the stack, because there are places where this routine - // is called twice before the results are used. + // 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 + // there is a refmod, the data location additionally gets augmented by + // (refmod.from-1) if( !refer.field ) { + // It's common for the field to be missing. It generally means that an + // optional parameter wasn't supplied. return size_t_zero_node; } - if( !refer.nsubscript ) + if( refer.field->type == FldLiteralN || refer.field->type == FldLiteralA ) { - return get_data_offset_dest(refer); + // We know that literals have no offset + return size_t_zero_node; } - gg_assign(var_decl_odo_violation, integer_zero_node); - - tree retval = gg_define_variable(SIZE_T); - gg_assign(retval, get_data_offset_dest(refer)); - if( process_this_exception(ec_bound_odo_e) ) - { - IF( var_decl_odo_violation, ne_op, integer_zero_node ) - { - if( enabled_exceptions.match(ec_bound_odo_e) ) - { - SET_EXCEPTION_CODE(ec_bound_odo_e); - } - else - { - rt_error("receiving item subscript not in DEPENDING ON range"); - } - } - ELSE - ENDIF - } + tree retval = get_data_offset(refer, pflags); return retval; } -tree // size_t -refer_size_dest(cbl_refer_t &refer) +static +tree // size_t +refer_size(cbl_refer_t &refer, refer_type_t refer_type) { Analyze(); - //static tree retval = gg_define_variable(SIZE_T, "..rsd_retval", vs_file_static); - tree retval = gg_define_variable(SIZE_T); + static tree retval = gg_define_variable(SIZE_T, "..rs_retval", vs_file_static); if( !refer.field ) { return size_t_zero_node; } + if( refer_is_clean(refer) ) { - // When the refer has no modifications, we return zero, which is interpreted - // as "use the original length" - if( refer.field->attr & (intermediate_e | any_length_e) ) - { - return member(refer.field->var_decl_node, "capacity"); - } - else - { - return build_int_cst_type(SIZE_T, refer.field->data.capacity); - } + return get_any_capacity(refer.field); } // Step the first: Get the actual full length: - if( refer.field->attr & (intermediate_e | any_length_e) ) - { - // This is an intermediate; use the length that might have changed - // because of a FUNCTION TRIM, or whatnot. - - // We also pick up capacity for variables that were specified in - // linkage as ANY LENGTH - gg_assign(retval, member(refer.field->var_decl_node, "capacity")); - } - if( refer_has_depends(refer, refer_dest) ) + if( refer_has_depends(refer, refer_type) ) { // Because there is a depends, we might have to change the length: gg_assign(retval, refer_fill_depends(refer)); } else { - // Use the compile-time value - gg_assign(retval, build_int_cst_type(SIZE_T, refer.field->data.capacity)); + gg_assign(retval, get_any_capacity(refer.field)); } if( refer.refmod.from || refer.refmod.len ) @@ -2520,7 +2061,7 @@ refer_size_dest(cbl_refer_t &refer) // retval is the ODO based total length. // refmod is the length resulting from refmod(from:len) // We have to reduce retval by the effect of refmod: - tree diff = gg_subtract(build_int_cst_type(SIZE_T, refer.field->data.capacity), + tree diff = gg_subtract(get_any_capacity(refer.field), refmod); gg_assign(retval, gg_subtract(retval, diff)); } @@ -2528,113 +2069,74 @@ refer_size_dest(cbl_refer_t &refer) } tree // size_t -refer_offset_source(cbl_refer_t &refer, - int *pflags) +refer_size_dest(cbl_refer_t &refer) { - if( !refer.field ) - { - return size_t_zero_node; - } - if( !refer.nsubscript ) - { - return get_data_offset_source(refer); - } - - Analyze(); - - tree retval = gg_define_variable(SIZE_T); - gg_assign(var_decl_odo_violation, integer_zero_node); - - gg_assign(retval, get_data_offset_source(refer, pflags)); - if( process_this_exception(ec_bound_odo_e) ) - { - IF( var_decl_odo_violation, ne_op, integer_zero_node ) - { - if( enabled_exceptions.match(ec_bound_odo_e) ) - { - SET_EXCEPTION_CODE(ec_bound_odo_e); - } - else - { - rt_error("sending item subscript not in DEPENDING ON range"); - } - } - ELSE - ENDIF - } - return retval; + return refer_size(refer, refer_dest); } tree // size_t refer_size_source(cbl_refer_t &refer) { - if( !refer.field ) - { - return size_t_zero_node; - } - if( refer_is_clean(refer) ) - { - // When the refer has no modifications, we return zero, which is interpreted - // as "use the original length" - if( refer.field->attr & (intermediate_e | any_length_e) ) - { - return member(refer.field->var_decl_node, "capacity"); - } - else - { - return build_int_cst_type(SIZE_T, refer.field->data.capacity); - } - } + /* 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 + have both a source and a dest. Given that refer_size returns a static, + there are ways that the source and dest can trip over each other. - Analyze(); + The logic here avoids all known cases where they might trip over each + other. But there conceivably might be others,. - // Step the first: Get the actual full length: - static tree retval = gg_define_variable(SIZE_T, "..rss_retval", vs_file_static); - if( refer.field->attr & (intermediate_e | any_length_e) ) - { - // This is an intermediate; use the length that might have changed - // because of a FUNCTION TRIM, or whatnot. + You have been warned. - // We also pick up capacity for variables that were specified in - // linkage as ANY LENGTH - gg_assign(retval, - member(refer.field->var_decl_node, "capacity")); - } + */ - if( refer_has_depends(refer, refer_source) ) - { - // Because there is a depends, we might have to change the length: - gg_assign(retval, refer_fill_depends(refer)); - } - else + // This test has to be here, otherwise there are failures in regression + // testing. + if( !refer.field ) { - // Use the compile-time value - gg_assign(retval, build_int_cst_type(SIZE_T, refer.field->data.capacity)); + return size_t_zero_node; } - if( refer.refmod.from || refer.refmod.len ) + // This test has to be here, otherwise there are failures in regression + // testing. + if( refer_is_clean(refer) ) { - tree refmod = refer_refmod_length(refer); - // retval is the ODO based total length. - // refmod is the length resulting from refmod(from:len) - // We have to reduce retval by the effect of refmod: - tree diff = gg_subtract(build_int_cst_type(SIZE_T, refer.field->data.capacity), - refmod); - gg_assign(retval, gg_subtract(retval, diff)); + return get_any_capacity(refer.field); } + + // This assignment has to be here. Simply returning refer_size() results + // in regression testing errors. + static tree retval = gg_define_variable(SIZE_T, "..rss_retval", vs_file_static); + gg_assign(retval, refer_size(refer, refer_source)); return retval; } tree -qualified_data_source(cbl_refer_t &refer) +qualified_data_location(cbl_refer_t &refer) { return gg_add(member(refer.field->var_decl_node, "data"), - refer_offset_source(refer)); + refer_offset(refer)); } -tree -qualified_data_dest(cbl_refer_t &refer) - { - return gg_add(member(refer.field->var_decl_node, "data"), - refer_offset_dest(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 6ef4dee..0d9028e 100644 --- a/gcc/cobol/genutil.h +++ b/gcc/cobol/genutil.h @@ -45,8 +45,6 @@ extern bool suppress_dest_depends; extern std::vector<std::string>current_filename; extern tree var_decl_exception_code; // int __gg__exception_code; -extern tree var_decl_exception_handled; // int __gg__exception_handled; -extern tree var_decl_exception_file_number; // int __gg__exception_file_number; extern tree var_decl_exception_file_status; // int __gg__exception_file_status; extern tree var_decl_exception_file_name; // const char *__gg__exception_file_name; extern tree var_decl_exception_statement; // const char *__gg__exception_statement; @@ -58,7 +56,6 @@ extern tree var_decl_exception_paragraph; // const char *__gg__exception_para extern tree var_decl_default_compute_error; // int __gg__default_compute_error; extern tree var_decl_rdigits; // int __gg__rdigits; -extern tree var_decl_odo_violation; // int __gg__odo_violation; extern tree var_decl_unique_prog_id; // size_t __gg__unique_prog_id; extern tree var_decl_entry_location; // This is for managing ENTRY statements @@ -95,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, @@ -123,7 +120,7 @@ void set_exception_code_func(ec_type_t ec, #define set_exception_code(ec) set_exception_code_func(ec, __LINE__) bool process_this_exception(ec_type_t ec); #define CHECK_FOR_FRACTIONAL_DIGITS true -void get_integer_value(tree value, +void get_integer_value(tree value, // This is always a LONG cbl_field_t *field, tree offset=NULL, // size_t bool check_for_fractional_digits=false); @@ -143,21 +140,12 @@ char *get_literal_string(cbl_field_t *field); bool refer_is_clean(cbl_refer_t &refer); -tree refer_offset_source(cbl_refer_t &refer, - int *pflags=NULL); +tree refer_offset(cbl_refer_t &refer, + int *pflags=NULL); tree refer_size_source(cbl_refer_t &refer); -tree refer_offset_dest(cbl_refer_t &refer); tree refer_size_dest(cbl_refer_t &refer); -void REFER_CHECK( const char *func, - int line, - cbl_refer_t &refer - ); -#define refer_check(a) REFER_CHECK(__func__, __LINE__, a) - -tree qualified_data_source(cbl_refer_t &refer); - -tree qualified_data_dest(cbl_refer_t &refer); +tree qualified_data_location(cbl_refer_t &refer); void build_array_of_treeplets( int ngroup, size_t N, @@ -166,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 42c4020..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 @@ -77,10 +82,6 @@ ffixed-form Cobol RejectNegative Assume that the source file is fixed form. -fsyntax-only -Cobol RejectNegative -; Documented in c.opt - ffree-form Cobol RejectNegative Assume that the source file is free form. @@ -93,10 +94,6 @@ finternal-ebcdic Cobol Var(cobol_ebcdic, 1) Init(0) -finternal-ebcdic Internal processing is in EBCDIC Code Page 1140 -fmax-errors -Cobol Joined Separate -; Documented in C - fstatic-call Cobol Var(cobol_static_call, 1) Init(1) Enable/disable static linkage for CALL literals @@ -118,7 +115,7 @@ Cobol Joined Separate ; Documented in C include -Cobol Joined Separate Var(cobol_include) +Cobol Joined Separate ; Documented in C isysroot diff --git a/gcc/cobol/lang.opt.urls b/gcc/cobol/lang.opt.urls index 6a5dc1c..78fc491 100644 --- a/gcc/cobol/lang.opt.urls +++ b/gcc/cobol/lang.opt.urls @@ -10,18 +10,15 @@ 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) -fsyntax-only -UrlSuffix(gcc/Warning-Options.html#index-fsyntax-only) LangUrlSuffix_D(gdc/Warnings.html#index-fno-syntax-only) LangUrlSuffix_Fortran(gfortran/Error-and-Warning-Options.html#index-fsyntax-only) - ffree-form LangUrlSuffix_Fortran(gfortran/Fortran-Dialect-Options.html#index-ffree-form) -fmax-errors -UrlSuffix(gcc/Warning-Options.html#index-fmax-errors) LangUrlSuffix_D(gdc/Warnings.html#index-fmax-errors) - iprefix UrlSuffix(gcc/Directory-Options.html#index-iprefix) LangUrlSuffix_D(gdc/Directory-Options.html#index-iprefix) LangUrlSuffix_Fortran(gfortran/Preprocessing-Options.html#index-iprefix) diff --git a/gcc/cobol/lexio.cc b/gcc/cobol/lexio.cc index 82bacf2..2d9fb72 100644 --- a/gcc/cobol/lexio.cc +++ b/gcc/cobol/lexio.cc @@ -28,6 +28,7 @@ * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ +#include "config.h" #include <ext/stdio_filebuf.h> #include "cobol-system.h" #include "cbldiag.h" @@ -45,8 +46,22 @@ static struct { first_file = false; return tf; } + inline bool is_fixed() const { return column == 7; } + inline bool is_reffmt() const { return is_fixed() && right_margin == 73; } + inline bool is_free() const { return ! is_fixed(); } + + const char * description() const { + if( is_reffmt() ) return "REFERENCE"; + if( is_fixed() ) return "FIXED"; + if( is_free() ) return "FREE"; + gcc_unreachable(); + } } indicator = { true, false, 0, 0 }; +// public source format test functions +bool is_fixed_format() { return indicator.is_fixed(); } +bool is_reference_format() { return indicator.is_reffmt(); } + static bool debug_mode = false; /* @@ -85,10 +100,6 @@ cobol_set_indicator_column( int column ) indicator.column = column; } -bool is_fixed_format() { return indicator.column == 7; } -bool is_reference_format() { - return indicator.column == 7 && indicator.right_margin == 73; -} bool include_debug() { return indicator.column == 7 && debug_mode; } bool set_debug( bool tf ) { return debug_mode = tf && is_fixed_format(); } @@ -112,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 } @@ -129,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 ) { @@ -197,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)); } } @@ -255,14 +266,17 @@ 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 ) { size_t n = count_newlines(mfile.data, found.p); - dbgmsg("%s:%d first '%.*s' is on line %zu (offset %zu)", __func__, __LINE__, + dbgmsg("%s:%d first '%.*s' is on line " HOST_SIZE_T_PRINT_UNSIGNED + " (offset " HOST_SIZE_T_PRINT_UNSIGNED ")", __func__, __LINE__, directive.before.size(), directive.before.p, - ++n, found.p - mfile.data); + (fmt_size_t)++n, (fmt_size_t)(found.p - mfile.data)); } } else { dbgmsg("%s:%d not found: '%s' in \n'%.*s'", __func__, __LINE__, @@ -289,9 +303,12 @@ 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'); - dbgmsg( "%s:%d: line %zu @ %zu: '%s'\n/%.*s/%.*s/", __func__, __LINE__, - ++n, next.found.p - mfile.data, + 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__, + (fmt_size_t)++n, (fmt_size_t)(next.found.p - mfile.data), next.directive.before.p, int(recognized.before.size()), recognized.before.p, int(recognized.after.size()), recognized.after.p ); @@ -303,14 +320,16 @@ 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 %zu (offset %zu)", __func__, __LINE__, + dbgmsg("%s:%d next '%.*s' will be on line " HOST_SIZE_T_PRINT_UNSIGNED + " (offset " HOST_SIZE_T_PRINT_UNSIGNED ")", __func__, __LINE__, next.directive.before.size(), next.directive.before.p, - ++n, next.found.p - mfile.data); + (fmt_size_t)++n, (fmt_size_t)(next.found.p - mfile.data)); } pnext = std::min_element(futures.begin(), futures.end()); } @@ -330,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: @@ -343,11 +362,14 @@ check_source_format_directive( filespan_t& mfile ) { gcc_assert(cm[3].length() == 4 || cm[3].length() == 5); break; } + + dbgmsg( "%s:%d: %s format set, on line " HOST_SIZE_T_PRINT_UNSIGNED, + __func__, __LINE__, + indicator.column == 7? "FIXED" : "FREE", + (fmt_size_t)mfile.lineno() ); + char *bol = indicator.is_fixed()? mfile.cur : const_cast<char*>(cm[0].first); + erase_line(bol, const_cast<char*>(cm[0].second)); mfile.cur = const_cast<char*>(cm[0].second); - dbgmsg( "%s:%d: %s format set, on line %zu", __func__, __LINE__, - indicator.column == 7? "FIXED" : "FREE", mfile.lineno() ); - erase_line(const_cast<char*>(cm[0].first), - const_cast<char*>(cm[0].second)); } } @@ -380,21 +402,28 @@ struct buffer_t : public bytespan_t { dbgmsg("flex input buffer: '%.*s'\n[xelf]", int(pos - data), data); } void dump() const { +#ifdef GETENV_OK if( getenv("lexer_input") ) show(); +#endif } }; -static bool -valid_sequence_area( const char *p, const char *eodata ) { - const char *pend = p + 6; - if ( eodata < pend ) return false; +static inline bool is_p( char ch ) { return TOUPPER(ch) == 'P'; } - for( ; p < pend; p++ ) { - if( ! (ISDIGIT(*p) || *p == SPACE) ) { - return false; +static bool +is_program_id( const char *p, const char *eol ) { + static const std::string program_id("PROGRAM-ID"); + auto eop = p + program_id.size(); + if( eop < eol ) { + // PROGRAM-ID must be followed by a dot, perhaps with intervening whitespace. + for( const char *dot=eop; dot < eol && *dot != '.'; dot++ ) { + if( !ISSPACE(*dot) ) return false; } + std::string line (p, eop); + std::transform(line.begin(), line.end(), line.begin(), ::toupper); + return line == program_id; } - return true; // characters either digits or blanks + return false; } const char * esc( size_t len, const char input[] ); @@ -434,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; @@ -457,11 +486,11 @@ update_yylloc( const csub_match& stmt, const csub_match& term ) { class dump_loc_on_exit { public: dump_loc_on_exit() { - if( getenv( "update_yylloc" ) ) + if( gcobol_getenv( "update_yylloc" ) ) location_dump( "update_yylloc", __LINE__, "begin", yylloc); } ~dump_loc_on_exit() { - if( getenv( "update_yylloc" ) ) + if( gcobol_getenv( "update_yylloc" ) ) location_dump( "update_yylloc", __LINE__, "end ", yylloc); } } dloe; @@ -506,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[] = @@ -716,13 +745,13 @@ 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" yywarn("CDF syntax error"); } - pair.stmt = span_t(0UL, stmt); + pair.stmt = span_t(size_t(0), stmt); pair.replace = replace_t(); } return pair; @@ -762,9 +791,9 @@ parse_replace_pairs( const char *stmt, const char *estmt, bool is_copy_stmt ) { // Report findings. if( false && yy_flex_debug ) { for( size_t i=0; i < cm.size(); i++ ) { - dbgmsg("%s: %s %zu: '%.*s'", __func__, + dbgmsg("%s: %s " HOST_SIZE_T_PRINT_UNSIGNED ": '%.*s'", __func__, cm[i].matched? "Pair" : "pair", - i, + (fmt_size_t)i, cm[i].matched? int(cm[i].length()) : 0, cm[i].matched? cm[i].first : ""); } @@ -784,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); @@ -823,9 +852,10 @@ parse_replace_pairs( const char *stmt, const char *estmt, bool is_copy_stmt ) { } if( yy_flex_debug ) { - dbgmsg( "%s:%d: %s: %zu pairs parsed from '%.*s'", __func__, __LINE__, - parsed.done()? "done" : "not done", - pairs.size(), parsed.stmt.size(), parsed.stmt.p ); + dbgmsg( "%s:%d: %s: " HOST_SIZE_T_PRINT_UNSIGNED " pairs parsed from '%.*s'", + __func__, __LINE__, + parsed.done() ? "done" : "not done", + (fmt_size_t)pairs.size(), parsed.stmt.size(), parsed.stmt.p ); int i = 0; for( const auto& replace : pairs ) { dbgmsg("%s:%d:%4d: '%s' => '%s'", __func__, __LINE__, @@ -851,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) @@ -902,14 +932,15 @@ 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); size_t nst = 1 + count_newlines(copy_stmt.p, copy_stmt.pend); - dbgmsg("%s:%d: line %zu: COPY directive is %zu lines '%.*s'", + dbgmsg("%s:%d: line " HOST_SIZE_T_PRINT_UNSIGNED + ": COPY directive is " HOST_SIZE_T_PRINT_UNSIGNED " lines '%.*s'", __func__, __LINE__, - nnl, nst, copy_stmt.size(), copy_stmt.p); + (fmt_size_t)nnl, (fmt_size_t)nst, copy_stmt.size(), copy_stmt.p); } } } @@ -922,7 +953,8 @@ parse_copy_directive( filespan_t& mfile ) { outcome.partial_line = span_t(mfile.cur, copy_stmt.p); if( yy_flex_debug ) { - dbgmsg("%zu expressions", std::count(pattern, pattern + sizeof(pattern), '(')); + dbgmsg(HOST_SIZE_T_PRINT_UNSIGNED " expressions", + (fmt_size_t)std::count(pattern, pattern + sizeof(pattern), '(')); int i = 0; for( const auto& m : cm ) { if( m.matched ) @@ -953,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); @@ -980,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:]]*[.]" @@ -990,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); @@ -1006,8 +1038,9 @@ parse_replace_last_off( filespan_t& mfile ) { } } - dbgmsg( "%s:%d: line %zu: parsed '%.*s', ", __func__, __LINE__, - mfile.lineno(), int(cm[0].length()), cm[0].first ); + dbgmsg( "%s:%d: line " HOST_SIZE_T_PRINT_UNSIGNED ": parsed '%.*s', ", + __func__, __LINE__, + (fmt_size_t)mfile.lineno(), int(cm[0].length()), cm[0].first ); // Remove statement from input erase_line(const_cast<char*>(cm[0].first), @@ -1039,20 +1072,23 @@ parse_replace_text( filespan_t& mfile ) { gcc_assert(mfile.line_length() > 2); if( pend[-1] == '\n' ) pend -= 2; auto len = int(pend - mfile.cur); - dbgmsg("%s:%d: line %zu: parsing '%.*s", __func__, __LINE__, - current_lineno, len, mfile.cur); + dbgmsg("%s:%d: line " HOST_SIZE_T_PRINT_UNSIGNED ": parsing '%.*s", + __func__, __LINE__, + (fmt_size_t)current_lineno, len, mfile.cur); } - if( ! regex_search(mfile.ccur(), (const char *)mfile.eodata, cm, re) ) { - dbgmsg( "%s:%d: line %zu: not a REPLACE statement:\n'%.*s'", - __func__, __LINE__, current_lineno, + 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, int(mfile.line_length()), mfile.cur ); return span_t(); } // Report findings. if( yy_flex_debug ) { - dbgmsg("%zu expressions", std::count(pattern, pattern + sizeof(pattern), '(')); + dbgmsg(HOST_SIZE_T_PRINT_UNSIGNED " expressions", + (fmt_size_t)std::count(pattern, pattern + sizeof(pattern), '(')); int i = 0; for( const auto& m : cm ) { if( m.matched ) @@ -1077,12 +1113,14 @@ 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 ) { - dbgmsg( "%s:%d: line %zu: %zu pairs parsed from '%.*s'", __func__, __LINE__, - current_lineno, replacements.size(), int(replace_stmt.size()), replace_stmt.p ); + dbgmsg( "%s:%d: line " HOST_SIZE_T_PRINT_UNSIGNED ": " HOST_SIZE_T_PRINT_UNSIGNED + " pairs parsed from '%.*s'", __func__, __LINE__, + (fmt_size_t)current_lineno, (fmt_size_t)replacements.size(), + int(replace_stmt.size()), replace_stmt.p ); for( const auto& replace : replacements ) { int i = 0; dbgmsg("%s:%d:%4d: '%s' => '%s'", __func__, __LINE__, @@ -1113,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; @@ -1162,8 +1200,9 @@ bytespan_t::append( const char *input, const char *eoinput ) { #if LEXIO auto nq = std::count_if(data, eodata, isquote); dbgmsg("%s:%3d: input ------ '%.*s'", __func__, __LINE__, int(eoinput - input), input); - dbgmsg("%s:%3d: precondition '%.*s' (%zu: %s)", __func__, __LINE__, - int(size()), data, nq, in_string()? "in string" : "not in string"); + dbgmsg("%s:%3d: precondition '%.*s' (" HOST_SIZE_T_PRINT_UNSIGNED ": %s)", + __func__, __LINE__, + int(size()), data, (fmt_size_t)nq, in_string()? "in string" : "not in string"); #endif if( !in_string() ) { // Remove trailing space unless it's part of a literal. while(data < eodata && ISSPACE(eodata[-1])) eodata--; @@ -1374,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) ); @@ -1420,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)) ) { @@ -1431,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 ) ); @@ -1453,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; @@ -1482,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 ) { @@ -1504,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"); @@ -1518,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)", @@ -1561,8 +1603,8 @@ cdftext::map_file( int fd ) { cbl_err( "%s: could not prepare map file from FIFO %d", __func__, input); } - if( false ) dbgmsg("%s: copied %ld bytes from FIFO", - __func__, nout); + if( false ) dbgmsg("%s: copied " HOST_SIZE_T_PRINT_DEC " bytes from FIFO", + __func__, (fmt_size_t)nout); } } } while( S_ISFIFO(sb.st_mode) ); @@ -1585,6 +1627,54 @@ cdftext::map_file( int fd ) { bool lexio_dialect_mf(); +/* + * A valid sequence area is 6 digits or blanks at the begining of the line that + * contains PROGRAM-ID. Return NULL if no valid sequence area, else return + * pointer to BOL. + */ +static const char * +valid_sequence_area( const char *data, const char *eodata ) { + + for( const char *p = data; + (p = std::find_if(p, eodata, is_p)) != eodata; + p++ ) + { + auto eol = std::find(p, eodata, '\n'); + if( p == data || ISSPACE(p[-1]) ) { + if( is_program_id(p, eol) ) { // found program-id token + const char *bol = p; + for( ; data <= bol-1 && bol[-1] != '\n'; --bol ) + ; + if( 6 < p - bol ) { + if( std::all_of(bol, bol+6, ::isdigit) ) { + return bol; + } + if( std::all_of(bol, bol+6, ::isblank) ) { + return bol; + } + break; + } + } + } + } + return nullptr; +} + +/* + * Reference Format -- valid COBOL between columns 8 and 72 -- has data after + * column 72 on the PROGRAM-ID line. Extended Reference Format (that allows + * longer lines) has no reason to follow the PROGRAM-ID with more stuff. + */ +static bool +infer_reference_format( const char *bol, const char *eodata ) { + assert(bol); + auto eol = std::find(bol, eodata, '\n'); + if( 72 < eol - bol ) { + return ! std::all_of(bol + 72, eol, ::isspace); + } + return false; +} + filespan_t cdftext::free_form_reference_format( int input ) { filespan_t source_buffer = map_file(input); @@ -1599,29 +1689,23 @@ 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 ); /* - * If the format is not explicitly set on the command line, test the - * first 6 bytes of the first file to determine the format - * heuristically. If the first 6 characters are only digits or - * blanks, then the file is in fixed format. + * Infer source code format. */ - if( indicator.inference_pending() ) { - const char *p = mfile.data; - while( p < mfile.eodata ) { - const char * pend = - std::find(p, const_cast<const char *>(mfile.eodata), '\n'); - if( 6 < pend - p ) break; - p = pend; - if( p < mfile.eodata) p++; + const char *bol = valid_sequence_area(mfile.data, mfile.eodata); + if( bol ) { + indicator.column = 7; + if( infer_reference_format(bol, mfile.eodata) ) { + indicator.right_margin = 73; + } } - if( valid_sequence_area(p, mfile.eodata) ) indicator.column = 7; dbgmsg("%s:%d: %s format detected", __func__, __LINE__, - indicator.column == 7? "FIXED" : "FREE"); + indicator.description()); } while( mfile.next_line() ) { @@ -1745,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(); @@ -1772,8 +1856,8 @@ cdftext::process_file( filespan_t mfile, int output, bool second_pass ) { std::copy_if(copied.erased_lines.p, copied.erased_lines.pend, ofs, []( char ch ) { return ch == '\n'; } ); struct { int in, out; filespan_t mfile; } copy; - dbgmsg("%s:%d: line %zu, opening %s on fd %d", __func__, __LINE__, - mfile.lineno(), + dbgmsg("%s:%d: line " HOST_SIZE_T_PRINT_UNSIGNED ", opening %s on fd %d", + __func__, __LINE__,mfile.lineno(), copybook.source(), copybook.current()->fd); copy.in = copybook.current()->fd; copy.mfile = free_form_reference_format( copy.in ); @@ -1809,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 @@ -1841,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> @@ -1856,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); } @@ -1877,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 61ffa7c..74637c9 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -28,6 +28,7 @@ * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ %code requires { + #include "config.h" #include <fstream> // Before cobol-system because it uses poisoned functions #include "cobol-system.h" #include "coretypes.h" @@ -187,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()) @@ -241,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 ) { @@ -279,6 +280,7 @@ } %{ +#include "config.h" #include <fstream> // Before cobol-system because it uses poisoned functions #include "cobol-system.h" #include "coretypes.h" @@ -330,7 +332,7 @@ NUMED "NUMERIC-EDITED picture" NUMED_CR "NUMERIC-EDITED CR picture" NUMED_DB "NUMERIC-EDITED DB picture" -%token <number> NINEDOT NINES NINEV PIC_P +%token <number> NINEDOT NINES NINEV PIC_P ONES %token <string> SPACES %token <literal> LITERAL %token <number> END EOP @@ -338,8 +340,8 @@ %token <number> INVALID %token <number> NUMBER NEGATIVE %token <numstr> NUMSTR "numeric literal" -%token <number> OVERFLOW -%token <computational> COMPUTATIONAL +%token <number> OVERFLOW_kw "OVERFLOW" +%token <computational> BINARY_INTEGER COMPUTATIONAL %token <boolean> PERFORM BACKWARD %token <number> POSITIVE @@ -373,7 +375,7 @@ LSUB "(" PARAMETER_kw "PARAMETER" OVERRIDE READY RESET - RSUB ")" + RSUB")" SERVICE_RELOAD "SERVICE RELOAD" STAR_CBL "*CBL" SUBSCRIPT SUPPRESS TITLE TRACE USE @@ -571,12 +573,12 @@ THAN TIME TIMES TO TOP TOP_LEVEL - TRACKS TRACK_AREA TRAILING TRANSFORM TRIM TRUE_kw "True" TRY - TURN TYPE TYPEDEF + TRACKS TRACK_AREA TRAILING TRANSFORM TRIM TRUE_kw "True" + TRY TURN TYPE TYPEDEF - ULENGTH UNBOUNDED UNIT UNITS UNIT_RECORD UNTIL UP UPON - UPOS UPPER_CASE USAGE USING USUBSTR USUPPLEMENTARY - UTILITY UUID4 UVALID UWIDTH + ULENGTH UNBOUNDED UNIT UNITS UNIT_RECORD UNTIL + UP UPON UPOS UPPER_CASE USAGE USING + USUBSTR USUPPLEMENTARY UTILITY UUID4 UVALID UWIDTH VALUE VARIANCE VARYING VOLATILE @@ -657,10 +659,10 @@ %type <number> star_cbl_opt close_how %type <number> test_before usage_clause1 might_be -%type <boolean> all optional sign_leading on_off initialized strong +%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 @@ -690,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 @@ -699,6 +701,7 @@ relative_key_clause reserve_clause sharing_clause %type <file> filename read_body write_body delete_body +%type <file> start_impl start_cond start_body %type <rewrite_t> rewrite_body %type <min_max> record_vary rec_contains from_to record_desc %type <file_op> read_file rewrite1 write_file @@ -712,7 +715,7 @@ %type <refer> move_tgt selected_name read_key read_into vary_by %type <refer> accept_refer num_operand envar search_expr any_arg %type <accept_func> accept_body -%type <refers> expr_list subscripts arg_list free_tgts +%type <refers> subscript_exprs subscripts arg_list free_tgts %type <targets> move_tgts set_tgts %type <field> search_varying %type <field> search_term search_terms @@ -729,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 @@ -798,7 +801,7 @@ %type <switches> upsi_entry -%type <special> acceptable disp_target +%type <special> acceptable disp_upon %type <display> disp_body %type <false_domain> domains domain @@ -828,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; @@ -837,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; @@ -877,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; @@ -945,18 +953,20 @@ %printer { fprintf(yyo, "%s (token %d)", keyword_str($$), $$ ); } relop %printer { fprintf(yyo, "'%s'", $$? $$ : "" ); } NAME <string> -%printer { fprintf(yyo, "%s'%.*s'{%zu} %s", $$.prefix, int($$.len), $$.data, $$.len, +%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 %zu)", +%printer { fprintf(yyo,"%s (1st of" HOST_SIZE_T_PRINT_UNSIGNED")", $$->targets.empty()? "" : $$->targets.front().refer.field->name, - $$->targets.size() ); } <targets> -%printer { fprintf(yyo, "#%zu: %s", - is_temporary($$)? 0 : field_index($$), + (fmt_size_t)$$->targets.size() ); } <targets> +%printer { fprintf(yyo, "#" HOST_SIZE_T_PRINT_UNSIGNED ": %s", + is_temporary($$)? 0 : (fmt_size_t)field_index($$), $$? name_of($$) : "<nil>" ); } name -%printer { fprintf(yyo, "{%zu-%zu}", $$.min, $$.max ); } <min_max> +%printer { fprintf(yyo, "{" HOST_SIZE_T_PRINT_UNSIGNED "-" HOST_SIZE_T_PRINT_UNSIGNED "}", + (fmt_size_t)$$.min, (fmt_size_t)$$.max ); } <min_max> %printer { fprintf(yyo, "{%s}", $$? "+/-" : "" ); } signed -%printer { fprintf(yyo, "{%s of %zu}", - teed_up_names().front(), teed_up_names().size() ); } qname +%printer { fprintf(yyo, "{%s of " HOST_SIZE_T_PRINT_UNSIGNED "}", + teed_up_names().front(), (fmt_size_t) teed_up_names().size() ); } qname %printer { fprintf(yyo, "{%d}", $$ ); } <number> %printer { fprintf(yyo, "'%s'", $$.string ); } <numstr> %printer { const char *s = string_of($$); @@ -968,9 +978,9 @@ $$.low? (const char*) $$.low : "", $$.high? (const char*) $$.high : "", $$.also? "+" : "" ); } <colseq> -%printer { fprintf(yyo, "{%s, %zu parameters}", +%printer { fprintf(yyo, "{%s, " HOST_SIZE_T_PRINT_UNSIGNED " parameters}", name_of($$.ffi_name->field), !$$.using_params? 0 : - $$.using_params->elems.size()); } call_body + (fmt_size_t)$$.using_params->elems.size()); } call_body %printer { fprintf(yyo, "%s <- %s", data_category_str($$.category), name_of($$.replacement->field)); } init_by @@ -997,7 +1007,7 @@ DELETE DISPLAY DIVIDE EVALUATE END EOP EXIT FILLER_kw GOBACK GOTO INITIALIZE INSPECT - MERGE MOVE MULTIPLY OPEN OVERFLOW PARAGRAPH PERFORM + MERGE MOVE MULTIPLY OPEN OVERFLOW_kw PARAGRAPH PERFORM READ RELEASE RETURN REWRITE SEARCH SET SELECT SORT SORT_MERGE STRING_kw STOP SUBTRACT START @@ -1315,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, @@ -1334,10 +1344,63 @@ return strlen(lit.data) == lit.len? lit.data : NULL; } + static inline void strip_trailing_zeroes(char * const psz) + { + if( yydebug) return; + // The idea here is to take the output of real_to_decimal and make it + // 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') + { + pnz--; + } + // pdot points to the decimal point. + // pe points to the 'e'. + // pnz points to the rightmost non-zero significand digit. + + // Put the exponent on top of the trailing zeroes: + memmove(pnz+1, pe, strlen(pe)+1); + pe = pnz+1; + int exp = atoi(pe+1); + // Compute the number digits to the right of the decimal point: + int non_zero_digits = pe - (pdot+1); + if( exp >= 1 && exp <= MAX_FIXED_POINT_DIGITS && non_zero_digits <= exp) + { + // Further simplification is possible, because the value does not actually + // need a decimal point. That's because we are dealing with something + // like 1.e+0, or 1.23e2 or 1.23e3 + + // Terminate the value where the 'e' is now: + *pe = '\0'; + // Figure out where the extra zeroes will go: + pe -= 1; + // Get rid of the decimal place: + memmove(pdot, pdot+1, strlen(pdot)+1); + // Tack on the additional zeroes: + for(int i=0; i<exp - non_zero_digits; i++) + { + *pe++ = '0'; + } + *pe++ = '\0'; + } + } + static inline char * string_of( const REAL_VALUE_TYPE &cce ) { char output[64]; real_to_decimal( output, &cce, sizeof(output), 32, 0 ); - + strip_trailing_zeroes(output); char decimal = symbol_decimal_point(); std::replace(output, output + strlen(output), '.', decimal); return xstrdup(output); @@ -1395,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 @@ -1423,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; } @@ -1459,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() ) { @@ -1501,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 @@ -1530,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] @@ -1658,9 +1723,9 @@ namestr: ctx_name { $$.prefix); YYERROR; } - if( !is_cobol_word($$.data) ) { + if( !is_cobol_charset($$.data) ) { error_msg(@1, "literal '%s' must be a COBOL or C identifier", - $$.data); + $$.data); } } ; @@ -1890,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]; } { @@ -1902,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: @@ -1972,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: @@ -2134,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; + } ; /* @@ -2227,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 ) { @@ -2238,8 +2318,8 @@ config_paragraph: } } } - | REPOSITORY '.' - | REPOSITORY '.' repo_members '.' + | REPOSITORY dot + | REPOSITORY dot repo_members '.' ; repo_members: repo_member @@ -2267,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 { @@ -2330,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); } ; @@ -2458,23 +2561,14 @@ dev_mnemonic: device_name is NAME } | NAME[device] is NAME[name] { - static const std::map< std::string, special_name_t > fujitsus - { // Fujitsu calls these "function names", not device names - { "ARGUMENT-NUMBER", ARG_NUM_e }, - { "ARGUMENT-VALUE", ARG_VALUE_e } , - { "ENVIRONMENT-NAME", ENV_NAME_e }, - { "ENVIRONMENT-VALUE", ENV_VALUE_e }, - }; - std::string device($device); - std::transform($device, $device + strlen($device), - device.begin(), toupper); - auto p = fujitsus.find(device.c_str()); - if( p == fujitsus.end() ) { - error_msg(@device, "%s is not a device name"); + auto p = cmd_or_env_special_of($device); + if( !p ) { + error_msg(@device, "%s is not a device name", $device); + YYERROR; } - cbl_special_name_t special = { 0, p->second }; - if( !namcpy(@name, special.name, $name) ) YYERROR; + cbl_special_name_t special = { 0, *p }; + namcpy(@name, special.name, $name); symbol_special_add(PROGRAM, &special); } @@ -2541,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); @@ -2594,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); } ; @@ -2778,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 @@ -2858,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; } @@ -2897,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; @@ -2934,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; } @@ -3130,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(); @@ -3236,11 +3333,11 @@ index_field1: ctx_name[name] field.data = data; if( !namcpy(@name, field.name, $name) ) YYERROR; - auto symbol = symbol_field(PROGRAM, 0, $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; } @@ -3306,21 +3403,16 @@ level_name: LEVEL ctx_name data_descr: data_descr1 { $$ = current_field($1); // make available for occurs, etc. - char *env = getenv("symbols_update"); - if( env && env[0] == 'P' ) { - dbgmsg("parse.y:%d: %-15s %s (%s)", __LINE__, - cbl_field_type_str($$->type) + 3, - field_str($$), - cbl_field_type_str($$->usage) + 3); - } } | error { static cbl_field_t none = {}; $$ = &none; } ; 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 @@ -3336,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"); @@ -3369,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; @@ -3408,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, @@ -3568,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; @@ -3610,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: @@ -3623,12 +3736,12 @@ data_descr1: level_name // SIGN clause valid only with "S" in picture if( $field->type == FldNumericDisplay && !is_signable($field) ) { - static const size_t sign_attrs = leading_e | separate_e; + static const uint64_t sign_attrs = leading_e | separate_e; static_assert(sizeof(sign_attrs) == sizeof($field->attr), "size matters"); // remove inapplicable inherited sign attributes - size_t group_sign = group_attr($field) & sign_attrs; + uint64_t group_sign = group_attr($field) & sign_attrs; $field->attr &= ~group_sign; if( $field->attr & sign_attrs ) { @@ -3688,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 } @@ -3784,7 +3897,7 @@ data_clauses: data_clause // If any implied TYPE bits are on in addition to // type_clause_e, they're in conflict. - static const size_t type_implies = + static const uint64_t type_implies = // ALIGNED clause not implemented blank_zero_clause_e | justified_clause_e | picture_clause_e | sign_clause_e | synched_clause_e | usage_clause_e; @@ -3821,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(); @@ -3915,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); } @@ -3981,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; } } @@ -4019,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; @@ -4061,7 +4175,13 @@ picture_clause: PIC signed nps[fore] nines nps[aft] gcc_unreachable(); } } + | PIC ones ; +ones: ONES + { + cbl_unimplemented("Boolean type not implemented"); + } + ; alphanum_pic: alphanum_part { current_field()->set_attr($1.attr); @@ -4092,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; } } @@ -4111,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)"); } } ; @@ -4125,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; @@ -4145,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 ); } } ; @@ -4170,11 +4290,21 @@ usage_clause: usage_clause1[type] } } ; -usage_clause1: usage COMPUTATIONAL[comp] native +usage_clause1: usage BIT + { + cbl_unimplemented("Boolean type not implemented"); + } +| usage BINARY_INTEGER [comp] is_signed { + // action for BINARY_INTEGER is repeated for COMPUTATIONAL, below. + // If it changes, consolidate in a function. bool infer = true; cbl_field_t *field = current_field(); + if( ! $is_signed ) { + $comp.signable = false; + } + // Some binary types have defined capacity; switch($comp.type) { // COMPUTATIONAL and COMP-5 rely on PICTURE. @@ -4190,20 +4320,102 @@ usage_clause1: usage COMPUTATIONAL[comp] native 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"); + "with Alpnanumeric PICTURE"); + 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; + field->data.capacity = type_capacity(field->type, + field->data.digits); + break; + default: break; + } + } + break; + case FldPacked: // comp-6 is unsigned comp-3 + assert(! $comp.signable); // else PACKED_DECIMAL from scanner + field->attr |= separate_e; + if( ! dialect_mf() ) { + dialect_error(@1, "COMP-6", "mf"); + } + if( field->type == FldNumericDisplay ) {// PICTURE before USAGE + infer = false; + assert(field->data.capacity > 0); + field->type = $comp.type; + field->data.capacity = type_capacity(field->type, + field->data.digits); + } + break; + default: + break; + } + + if( infer ) { + if( $comp.capacity > 0 ) { + if( field->data.capacity > 0 ) { + error_msg(@comp, "%s is BINARY type, incompatible with PICTURE", + field->name); + YYERROR; + } + field->data.capacity = $comp.capacity; + field->type = $comp.type; + if( $comp.signable ) { + field->attr = (field->attr | signable_e); + } + } + } + $$ = $comp.type; + } + | usage COMPUTATIONAL[comp] native + { + // logic below duplicates BINARY_INTEGER, above. + // If it changes, consolidate in a function. + bool infer = true; + cbl_field_t *field = current_field(); + + // Some binary types have defined capacity; + switch($comp.type) { + // COMPUTATIONAL and COMP-5 rely on PICTURE. + case FldNumericBinary: + field->attr |= big_endian_e; + __attribute__((fallthrough)); + case FldNumericBin5: + // If no capacity yet, then no picture, infer $comp.capacity. + // If field has capacity, ensure USAGE is compatible. + if( field->data.capacity > 0 ) { // PICTURE before USAGE + infer = false; + switch( field->type ) { + case FldAlphanumeric: // PIC X COMP-5 or COMP-X + assert( field->data.digits == 0 ); + assert( field->data.rdigits == 0 ); + 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 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_gnu()) ) { + dialect_error(@1, "COMP-X", "mf or gnu"); } } field->type = $comp.type; @@ -4285,8 +4497,9 @@ usage_clause1: usage COMPUTATIONAL[comp] native is_numeric(redefined->type) && redefined->size() == 4) { // For now, we allow POINTER to expand a 32-bit item to 64 bits. field->data.capacity = int_size_in_bytes(ptr_type_node); - dbgmsg("%s: expanding #%zu %s capacity %u => %u", __func__, - field_index(redefined), redefined->name, + dbgmsg("%s: expanding #" HOST_SIZE_T_PRINT_UNSIGNED + " %s capacity %u => %u", __func__, + (fmt_size_t)field_index(redefined), redefined->name, redefined->data.capacity, field->data.capacity); redefined->embiggen(); @@ -4529,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 ); } ; @@ -4540,7 +4753,7 @@ sign_clause: sign_is sign_leading sign_separate if( $sign_leading ) { field->attr |= leading_e; } else { - field->attr &= ~size_t(leading_e); // turn off in case inherited + field->attr &= ~uint64_t(leading_e); // turn off in case inherited field->attr |= signable_e; } if( $sign_separate ) field->attr |= separate_e; @@ -4578,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 ); } } @@ -4590,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 ); } } @@ -4803,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; } } @@ -4894,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 @@ -4906,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, @@ -5103,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($$); } ; @@ -5222,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] { @@ -5260,8 +5479,8 @@ 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()); - if( real_isneg(size) || real_iszero(size) ) { + 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; } @@ -5301,7 +5520,7 @@ compute_impl: COMPUTE compute_body[body] { parser_assign( $body.ntgt, $body.tgts, *$body.expr, NULL, NULL, current.compute_label() ); - current.declaratives_evaluate(ec_none_e); + current.declaratives_evaluate(); } ; compute_cond: COMPUTE compute_body[body] arith_errs[err] @@ -5309,7 +5528,7 @@ compute_cond: COMPUTE compute_body[body] arith_errs[err] parser_assign( $body.ntgt, $body.tgts, *$body.expr, $err.on_error, $err.not_error, current.compute_label() ); - current.declaratives_evaluate(ec_size_e); + current.declaratives_evaluate(); } ; end_compute: %empty %prec COMPUTE @@ -5347,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 { @@ -5355,7 +5574,7 @@ display: disp_body end_display args.empty()? NULL : args.data(), args.size(), DISPLAY_ADVANCE); } - current.declaratives_evaluate(ec_none_e); + current.declaratives_evaluate(); } | disp_body NO ADVANCING end_display { @@ -5366,15 +5585,15 @@ 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 { parser_display($1.special, - args.empty()? NULL : args.data(), args.size(), + args.empty()? NULL : args.data(), args.size(), DISPLAY_NO_ADVANCE); } - current.declaratives_evaluate(ec_none_e); + current.declaratives_evaluate(); } ; end_display: %empty @@ -5385,7 +5604,7 @@ disp_body: disp_vargs[vargs] $$.special = NULL; $$.vargs = $vargs; } - | disp_vargs[vargs] UPON disp_target[special] + | disp_vargs[vargs] UPON disp_upon[special] { $$.special = $special; $$.vargs = $vargs; @@ -5397,17 +5616,25 @@ disp_vargs: DISPLAY vargs { } ; -disp_target: device_name { +disp_upon: device_name { $$ = symbol_special($1.id); } | NAME { - symbol_elem_t *e = symbol_special(PROGRAM, $1); + symbol_elem_t *e = symbol_special(PROGRAM, $NAME); if( !e ) { - error_msg(@NAME, "no such special name '%s'", $NAME); - YYERROR; - } - $$ = cbl_special_name_of(e); + 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); + + e = symbol_special_add(PROGRAM, &special); + } + $$ = cbl_special_name_of(e); } ; @@ -5506,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; } @@ -5518,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; @@ -5537,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; } ; @@ -5613,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)) ); } @@ -6197,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; @@ -6302,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, $$); } } @@ -6313,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; } } @@ -6350,14 +6578,14 @@ tableish: name subscripts[subs] refmod[ref] %prec NAME refmod: LPAREN expr[from] ':' expr[len] ')' %prec NAME { - if( ! require_numeric(@from, *$from) ) YYERROR; - if( ! require_numeric(@len, *$len) ) YYERROR; + if( ! require_integer(@from, *$from) ) YYERROR; + if( ! require_integer(@len, *$len) ) YYERROR; $$.from = $from; $$.len = $len; } | LPAREN expr[from] ':' ')' %prec NAME { - if( ! require_numeric(@from, *$from) ) YYERROR; + if( ! require_integer(@from, *$from) ) YYERROR; $$.from = $from; $$.len = nullptr; } @@ -6590,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; } @@ -6863,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() ); @@ -6973,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); + } } } } @@ -7018,7 +7267,7 @@ stop_status: status { $$ = NULL; } } ; -subscripts: LPAREN expr_list ')' { +subscripts: LPAREN subscript_exprs ')' { $$ = $2; const auto& exprs( $$->refers ); bool ok = std::all_of( exprs.begin(), exprs.end(), @@ -7038,18 +7287,18 @@ subscripts: LPAREN expr_list ')' { } } ; -expr_list: expr +subscript_exprs: expr { - if( ! require_numeric(@expr, *$expr) ) YYERROR; + if( ! require_integer(@expr, *$expr) ) YYERROR; $$ = new refer_list_t($expr); } - | expr_list expr { + | subscript_exprs expr { if( $1->size() == MAXIMUM_TABLE_DIMENSIONS ) { error_msg(@1, "table dimensions limited to %d", MAXIMUM_TABLE_DIMENSIONS); YYERROR; } - if( ! require_numeric(@expr, *$expr) ) YYERROR; + if( ! require_integer(@expr, *$expr) ) YYERROR; $1->push_back($2); $$ = $1; } | ALL { @@ -7077,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(); @@ -7331,6 +7589,7 @@ perform_inline: perform_start statements END_PERFORM } } ; + perform_start: %empty %prec LOCATION { perform_ec_setup(); $$ = 0; @@ -7357,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"); } ; @@ -7386,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); @@ -7476,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 { @@ -7490,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 { @@ -7504,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); } ; @@ -7646,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() ); @@ -7670,6 +7927,10 @@ varg1a: ADDRESS OF scalar { } ; +binary_type: BINARY_INTEGER { $$ = $1.capacity; } + | COMPUTATIONAL { $$ = $1.capacity; } + ; + literal: literalism { $$ = $1.isymbol()? @@ -7713,14 +7974,14 @@ raise: RAISE EXCEPTION NAME "EXCEPTION CONDITION: %s", $NAME); YYERROR; } - cbl_unimplemented("RAISE <EXCEPTION OBJECT>"); + cbl_unimplemented("RAISE %<EXCEPTION OBJECT%>"); YYERROR; } ; read: read_file { - current.declaratives_evaluate($1.file, $1.handled); + current.declaratives_evaluate($1.file); } ; @@ -7780,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; @@ -7794,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; } @@ -7907,7 +8164,7 @@ read_key: %empty { $$ = new cbl_refer_t(); } write: write_file { - current.declaratives_evaluate( $1.file, $1.handled ); + current.declaratives_evaluate($1.file ); } ; @@ -8123,7 +8380,7 @@ end_delete: %empty %prec DELETE rewrite: rewrite1 { - current.declaratives_evaluate($1.file, $1.handled); + current.declaratives_evaluate($1.file); } ; @@ -8164,12 +8421,21 @@ end_rewrite: %empty %prec REWRITE ; start: start_impl end_start + { + current.declaratives_evaluate($1); + } | start_cond end_start + { + current.declaratives_evaluate($1); + } ; -start_impl: START start_body +start_impl: START start_body { + $$ = $2; + } ; start_cond: START start_body io_invalids { parser_fi(); + $$ = $2; } ; end_start: %empty %prec START @@ -8179,7 +8445,7 @@ end_start: %empty %prec START start_body: filename[file] { statement_begin(@$, START); - file_start_args.init(@file, $file); + $$ = file_start_args.init(@file, $file); parser_file_start( $file, lt_op, 0 ); } | filename[file] KEY relop name[key] @@ -8193,26 +8459,26 @@ start_body: filename[file] yywarn("START: key #%d '%s' has size %d", key, $key->name, size); } - file_start_args.init(@file, $file); + $$ = file_start_args.init(@file, $file); parser_file_start( $file, relop_of($relop), key, ksize ); } | filename[file] KEY relop name[key] with LENGTH expr { // lexer swallows IS, although relop allows it. statement_begin(@$, START); int key = $file->key_one($key); - file_start_args.init(@file, $file); + $$ = file_start_args.init(@file, $file); parser_file_start( $file, relop_of($relop), key, *$expr ); } | filename[file] FIRST { statement_begin(@$, START); - file_start_args.init(@file, $file); + $$ = file_start_args.init(@file, $file); parser_file_start( $file, lt_op, -1 ); } | filename[file] LAST { statement_begin(@$, START); - file_start_args.init(@file, $file); + $$ = file_start_args.init(@file, $file); parser_file_start( $file, gt_op, -2 ); } ; @@ -8222,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(); @@ -8242,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 ); @@ -8409,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)); @@ -8434,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 @@ -8574,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; } @@ -8620,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); @@ -8631,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 ); } ; @@ -8674,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 ); @@ -8866,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 { @@ -8878,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 { @@ -8890,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; @@ -8908,6 +9173,19 @@ inspect: INSPECT backward inspected TALLYING tallies error_msg(@all, "ALL must be part of a figurative constant"); YYERROR; } + } else { + cbl_field_t *match = $match->field, + *replace = $replace_oper->field; + if( is_literal(match) && is_literal(replace) ) { + if( !$match->all && !$replace_oper->all) { + if( match->data.capacity != replace->data.capacity ) { + 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; + } + } + } } if( is_constant($inspected->field) ) { auto name = nice_name_of($inspected->field); @@ -8927,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 { @@ -8937,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"); @@ -8954,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; @@ -9010,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); } ; @@ -9059,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 @@ -9073,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) ); @@ -9089,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 { @@ -9113,6 +9387,7 @@ insp_quals: insp_qual { } else { $$->after = *$insp_qual.qual; } + dump_inspect_match(*$$); } | insp_quals insp_qual { @@ -9272,7 +9547,7 @@ call_impl: CALL call_body[body] cbl_ffi_arg_t *pargs = NULL; if( narg > 0 ) { std::copy( params->elems.begin(), - params->elems.end(), args.begin() ); + params->elems.end(), args.begin() ); pargs = args.data(); } ast_call( $body.loc, *$body.ffi_name, @@ -9289,15 +9564,13 @@ call_cond: CALL call_body[body] call_excepts[except] cbl_ffi_arg_t *pargs = NULL; if( narg > 0 ) { std::copy( params->elems.begin(), - params->elems.end(), args.begin() ); + params->elems.end(), args.begin() ); pargs = args.data(); } ast_call( $body.loc, *$body.ffi_name, *$body.ffi_returning, narg, pargs, $except.on_error, $except.not_error, false ); - auto handled = ec_type_t( static_cast<size_t>(ec_program_e) | - static_cast<size_t>(ec_external_e)); - current.declaratives_evaluate(handled); + current.declaratives_evaluate(); } ; end_call: %empty %prec CALL @@ -9495,7 +9768,7 @@ call_except: EXCEPTION std::swap($$.on_error, $$.not_error); } } - | OVERFLOW + | OVERFLOW_kw { $$.not_error = NULL; $$.on_error = label_add(LblArith, @@ -9503,7 +9776,7 @@ call_except: EXCEPTION if( !$$.on_error ) YYERROR; parser_call_exception( $$.on_error ); - assert( $1 == OVERFLOW || $1 == NOT ); + assert( $1 == OVERFLOW_kw || $1 == NOT ); if( $1 == NOT ) { std::swap($$.on_error, $$.not_error); } @@ -9534,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); } @@ -9637,14 +9910,14 @@ string: string_impl end_string string_impl: STRING_kw string_body[body] { stringify($body.inputs, *$body.into.first, *$body.into.second); - current.declaratives_evaluate(ec_none_e); + current.declaratives_evaluate(); } ; string_cond: STRING_kw string_body[body] on_overflows[over] { stringify($body.inputs, *$body.into.first, *$body.into.second, $over.on_error, $over.not_error); - current.declaratives_evaluate(ec_overflow_e); + current.declaratives_evaluate(); } ; end_string: %empty %prec LITERAL @@ -9758,7 +10031,7 @@ on_overflows: on_overflow[over] statements %prec ADD } ; -on_overflow: OVERFLOW +on_overflow: OVERFLOW_kw { $$.not_error = NULL; $$.on_error = label_add(LblString, @@ -9766,7 +10039,7 @@ on_overflow: OVERFLOW if( !$$.on_error ) YYERROR; parser_string_overflow( $$.on_error ); - assert( $1 == OVERFLOW || $1 == NOT ); + assert( $1 == OVERFLOW_kw || $1 == NOT ); if( $1 == NOT ) { std::swap($$.on_error, $$.not_error); } @@ -9783,14 +10056,14 @@ end_unstring: %empty %prec UNSTRING unstring_impl: UNSTRING unstring_body[body] { unstringify( *$body.input, $body.delimited, $body.into ); - current.declaratives_evaluate(ec_none_e); + current.declaratives_evaluate(); } ; unstring_cond: UNSTRING unstring_body[body] on_overflows[over] { unstringify( *$body.input, $body.delimited, $body.into, $over.on_error, $over.not_error ); - current.declaratives_evaluate(ec_overflow_e); + current.declaratives_evaluate(); } ; @@ -9925,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); @@ -9944,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 ); @@ -9965,7 +10242,6 @@ function_udf: FUNCTION_UDF '(' arg_list[args] ')' { * var: [ALL] LITERAL, NUMSTR, instrinsic, or scalar * num_operand: signed NUMSTR/ZERO, instrinsic, or scalar * alpahaval: LITERAL, reserved_value, instrinsic, or scalar - * Probably any numeric argument could be an expression. */ intrinsic: function_udf | intrinsic0 @@ -9978,87 +10254,91 @@ 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() ); } - | PRESENT_VALUE '(' expr_list[args] ')' + | PRESENT_VALUE '(' arg_list[args] ')' { 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 ) { - error_msg(@args, "PRESENT VALUE requires 2 parameters"); + error_msg(@args, "PRESENT-VALUE requires 2 parameters"); YYERROR; } std::vector <cbl_refer_t> args(n); std::copy( $args->begin(), $args->end(), args.begin() ); + bool ok = std::all_of( args.begin(), + args.end(), [loc = @1]( auto r ) { + return require_numeric(loc, r); } ); + if( ! ok ) YYERROR; parser_intrinsic_callv( $$, s, args.size(), args.data() ); } | 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; } @@ -10067,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, @@ -10076,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; @@ -10087,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, @@ -10102,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; @@ -10124,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; @@ -10139,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; @@ -10154,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; @@ -10162,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 ) { @@ -10256,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 ); } @@ -10283,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; } @@ -10298,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; } @@ -10315,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) ) { @@ -10340,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; } @@ -10356,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; } @@ -10372,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; } @@ -10381,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; } @@ -10398,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; } @@ -10414,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; } @@ -10423,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; } @@ -10440,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; } @@ -10456,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; } @@ -10465,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; } @@ -10473,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 @@ -10522,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; } ; @@ -10602,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" ); } ; @@ -10864,6 +11142,11 @@ sign: %empty | SIGN ; +is_signed: %empty { $$ = true; } + | SIGNED_kw { $$ = true; } + | UNSIGNED_kw { $$ = false; } + ; + start_after: %empty %prec AFTER | START AFTER varg ; @@ -10912,7 +11195,12 @@ cdf_basis: BASIS NAME /* BASIS is never passed to the parser. */ | BASIS LITERAL ; -cdf_use: USE DEBUGGING on labels +cdf_use: cdf_use_when { + statement_cleanup = false; + } + ; + +cdf_use_when: USE DEBUGGING on labels { if( ! current.declarative_section_name() ) { error_msg(@1, "USE valid only in DECLARATIVES"); @@ -10930,12 +11218,11 @@ cdf_use: USE DEBUGGING on labels } static const cbl_label_t all = { LblNone, 0, 0,0,0, false, false, false, 0,0, ":all:" }; - ////.name = { ':', 'a', 'l', 'l', ':', } // workaround for gcc < 11.3 add_debugging_declarative(&all); } | USE globally mistake procedure on filenames - { + { // Format 1 if( ! current.declarative_section_name() ) { error_msg(@1, "USE valid only in DECLARATIVES"); YYERROR; @@ -10947,8 +11234,8 @@ cdf_use: USE DEBUGGING on labels std::back_inserter(files), file_list_t::symbol_index ); cbl_declarative_t declarative(current.declarative_section(), - ec_all_e, files, - file_mode_none_e, global); + ec_io_e, files, + file_mode_any_e, global); current.declaratives.add(declarative); } @@ -10961,12 +11248,12 @@ cdf_use: USE DEBUGGING on labels bool global = $globally == GLOBAL; std::list<size_t> files; cbl_declarative_t declarative(current.declarative_section(), - ec_all_e, files, + ec_io_e, files, $io_mode, global); current.declaratives.add(declarative); } - | USE cdf_use_excepts // Format 3: AFTER swallowed by lexer - { + | USE cdf_use_excepts + { // Format 3 (AFTER swallowed by lexer) if( ! current.declarative_section_name() ) { error_msg(@1, "USE valid only in DECLARATIVES"); YYERROR; @@ -11061,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, @@ -11078,43 +11365,74 @@ void ast_call( const YYLTYPE& loc, cbl_refer_t name, cbl_refer_t returning, parser_symbol_add(name.field); } - if( getenv("ast_call") ) { - dbgmsg("%s: calling %s returning %s with %zu args:", __func__, - name_of(name.field), - (returning.field)? returning.field->name : "[none]", - narg); - for( size_t i=0; i < narg; i++ ) { - const char *crv = "?"; - switch(args[i].crv) { - case by_default_e: crv = "def"; break; - case by_reference_e: crv = "ref"; break; - case by_content_e: crv = "con"; break; - case by_value_e: crv = "val"; break; - } - dbgmsg("%s: %4zu: %s @%p %s", __func__, - i, crv, args[i].refer.field, args[i].refer.field->name); - } - } parser_call( name, returning, narg, args, except, not_except, is_function ); } -static size_t -statement_begin( const YYLTYPE& loc, int token ) { - // The following statement generates a message at run-time - // parser_print_string("statement_begin()\n"); - location_set(loc); - prior_statement = token; - - parser_statement_begin(); +/* + * Check if any EC *could* be raised that would be handled by a declarative. If + * so, the generated statement epilog will ask the runtime library to attempt + * to match any raised EC with a declarative. If not, the statement epilog + * will be limited to calling the default EC handler, which logs unhandled ECs + * [todo] and calls abort(3) for fatal ECs. + */ +static bool +possible_ec() { + bool format_1 = current.declaratives.has_format_1(); + + bool enabled = 0xFF < (current.declaratives.status() + & + enabled_exceptions.status()); + bool epilog = enabled || format_1; + + dbgmsg("%sEC handling for DCL %08x && EC %08x with %s Format 1", + epilog? "" : "no ", + current.declaratives.status(), + enabled_exceptions.status(), format_1? "a" : "no"); + + return epilog; +} - if( token != CONTINUE ) { +/* + * If there's potential overlap between enabled ECs and Declaratives, generate + * a PERFORM of the _DECLARATIVES_EVAL "ladder" that matches a section number + * to its name, and executes the Declarative. + */ +static void +statement_epilog( int token ) { + if( possible_ec() && token != CONTINUE ) { if( enabled_exceptions.size() ) { - current.declaratives_evaluate(ec_none_e); - cbl_enabled_exceptions_array_t enabled(enabled_exceptions); - parser_exception_prepare( keyword_str(token), &enabled ); + current.declaratives_evaluate(); } } - return 0; + parser_check_fatal_exception(); +} + +static inline void +statement_prolog( int token ) { + parser_statement_begin( keyword_str(token), + current.declaratives.runtime.ena, + current.declaratives.runtime.dcl ); +} + +/* + * We check the EC against the Declarative status prior to parsing the + * statement because a TURN directive can be embedded in the statement. An + * embedded directive applies to the following statement, not the one being + * parsed. + */ +static void +statement_begin( const YYLTYPE& loc, int token ) { + static int prior_token = 0; + + if( statement_cleanup ) { + statement_epilog(prior_token); + } else { + statement_cleanup = true; + } + location_set(loc); + statement_prolog(token); + + prior_token = token; } #include "parse_util.h" @@ -11122,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); } @@ -11130,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; @@ -11156,6 +11478,8 @@ tokenset_t::tokenset_t() { #include "token_names.h" } +bool iso_cobol_word( const std::string& name, bool include_context ); + // Look up the lowercase form of a keyword, excluding some CDF names. int tokenset_t::find( const cbl_name_t name, bool include_intrinsics ) { @@ -11174,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); @@ -11185,17 +11509,25 @@ tokenset_t::find( const cbl_name_t name, bool include_intrinsics ) { } } + /* + * The input name may be one of: + * 1. an intrinsic function name (OK if include_intrinsics) + * 2. an ISO/GCC reserved word or context-sensitive word (OK) + * 3. a token in our token list for convenience, such as BINARY_INTEGER (bzzt) + */ + cbl_name_t lname; - std::transform(name, name + strlen(name) + 1, lname, tolower); + std::transform(name, name + strlen(name) + 1, lname, ftolower); auto p = tokens.find(lname); if( p == tokens.end() ) return 0; int token = p->second; if( token == SECTION ) yylval.number = 0; - if( include_intrinsics ) return token; - - return intrinsic_cname(token)? 0 : token; + if( include_intrinsics && intrinsic_cname(token) ) return token; + if( iso_cobol_word(uppercase(name), true) ) return token; + + return 0; } int @@ -11205,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; } @@ -11251,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 } @@ -11403,11 +11735,6 @@ label_add( const YYLTYPE& loc, assert( !(p->type == LblSection && p->parent > 0) ); - if( getenv(__func__) ) { - yywarn("%s: added label %3zu %10s for '%s' of %zu", __func__, - symbol_elem_of(p) - symbols_begin(), p->type_str()+3, p->name, p->parent); - } - return p; } @@ -11428,7 +11755,7 @@ perform_t::ec_labels_t::new_label( cbl_label_type_t type, { size_t n = 1 + symbols_end() - symbols_begin(); cbl_name_t name; - sprintf(name, "_perf_%s_%zu", role, n); + sprintf(name, "_perf_%s_" HOST_SIZE_T_PRINT_UNSIGNED, role, (fmt_size_t)n); return label_add( type, name, yylineno ); } @@ -11468,20 +11795,12 @@ paragraph_reference( const char name[], size_t section ) strcpy(label.name, name); if( label.type == LblNone ) assert(label.parent == 0); - const symbol_elem_t *last = symbols_end(); - p = symbol_label_add(PROGRAM, &label); assert(p); const char *sect_name = section? cbl_label_of(symbol_at(section))->name : NULL; procedure_reference_add(sect_name, p->name, yylineno, current.program_section()); - if( getenv(__func__) ) { - yywarn("%s: %s label %3zu %10s for '%s' of %zu", __func__, - symbols_end() == last? "added" : "found", - symbol_index(symbol_elem_of(p)), p->type_str()+3, p->name, p->parent); - } - return p; } @@ -11510,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()); @@ -11552,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; @@ -11573,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 ) { @@ -11609,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; @@ -11623,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 * @@ -11675,14 +11997,9 @@ ast_add( arith_t *arith ) { pC = use_any(arith->tgts, C); pA = use_any(arith->A, A); - if( getenv(__func__) ) { - dbgmsg("%s:%d: %-12s C{%zu %p} A{%zu %p}", __func__, __LINE__, - arith->format_str(), nC, pC, nA, pA ); - } parser_add( nC, pC, nA, pA, arith->format, arith->on_error, arith->not_error ); - ec_type_t handled = arith->on_error || arith->not_error ? ec_size_e : ec_none_e; - current.declaratives_evaluate(handled); + current.declaratives_evaluate(); } static bool @@ -11698,8 +12015,7 @@ ast_subtract( arith_t *arith ) { parser_subtract( nC, pC, nA, pA, nB, pB, arith->format, arith->on_error, arith->not_error ); - ec_type_t handled = arith->on_error || arith->not_error ? ec_size_e : ec_none_e; - current.declaratives_evaluate(handled); + current.declaratives_evaluate(); return true; } @@ -11716,8 +12032,7 @@ ast_multiply( arith_t *arith ) { parser_multiply( nC, pC, nA, pA, nB, pB, arith->on_error, arith->not_error ); - ec_type_t handled = arith->on_error || arith->not_error ? ec_size_e : ec_none_e; - current.declaratives_evaluate(handled); + current.declaratives_evaluate(); return true; } @@ -11735,8 +12050,7 @@ ast_divide( arith_t *arith ) { parser_divide( nC, pC, nA, pA, nB, pB, arith->remainder, arith->on_error, arith->not_error ); - ec_type_t handled = arith->on_error || arith->not_error ? ec_size_e : ec_none_e; - current.declaratives_evaluate(handled); + current.declaratives_evaluate(); return true; } @@ -11746,30 +12060,30 @@ 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 ); } static void dump( const cbl_string_src_t& src ) { - dbgmsg( "%s:%d:, %zu inputs delimited by %s:", __func__, __LINE__, - src.ninput, + dbgmsg( "%s:%d:, " HOST_SIZE_T_PRINT_UNSIGNED " inputs delimited by %s:", + __func__, __LINE__, (fmt_size_t)src.ninput, src.delimited_by.field? field_str(src.delimited_by.field) : "SIZE" ); std::for_each(src.inputs, src.inputs + src.ninput, dump_input); } 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 ) { @@ -11780,14 +12094,11 @@ stringify( refer_collection_t *inputs, } assert( inputs->lists.back().marker ); std::copy( inputs->lists.begin(), inputs->lists.end(), sources.begin() ); - if( yydebug && getenv(__func__) ) { - std::for_each(sources.begin(), sources.end(), stringify_src_t::dump); - } parser_string( into, pointer, sources.size(), sources.data(), on_error, not_error ); } 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, @@ -11795,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 ); @@ -11906,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 %zu operations on %s, line %d", __func__, __LINE__, - 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 * @@ -11926,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] ); @@ -12050,6 +12367,7 @@ static REAL_VALUE_TYPE numstr2i( const char input[], radix_t radix ) { REAL_VALUE_TYPE output; size_t integer = 0; + fmt_size_t integerf = 0; int erc=0; switch( radix ) { @@ -12061,13 +12379,14 @@ numstr2i( const char input[], radix_t radix ) { } break; case hexadecimal_e: - erc = sscanf(input, "%zx", &integer); + erc = sscanf(input, "%" GCC_PRISZ "x", &integerf); + 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) { @@ -12077,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; } } @@ -12085,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; } @@ -12111,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; @@ -12125,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 ); @@ -12133,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; @@ -12157,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); @@ -12183,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); @@ -12192,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, @@ -12227,9 +12547,6 @@ initialize_one( cbl_num_result_t target, bool with_filler, } else { parser_move(tgt, src, current_rounded_mode()); } - if( getenv(__func__) ) { - yywarn("%s:%-5s: %s", __func__, keyword_str(token), field_str(tgt.field)); - } return true; } @@ -12246,10 +12563,6 @@ initialize_one( cbl_num_result_t target, bool with_filler, parser_initialize(tgt); } } - - if( getenv(__func__) ) { - yywarn("%s: value: %s", __func__, field_str(tgt.field)); - } } // apply REPLACING, possibly overwriting VALUE @@ -12262,87 +12575,24 @@ initialize_one( cbl_num_result_t target, bool with_filler, if( r != replacements.end() ) { parser_move( tgt, *r->second ); - if( getenv(__func__) ) { - cbl_field_t *from = r->second->field; - char from_str[128]; // copy static buffer from field_str - strcpy( from_str, field_str(from) ); - yywarn("%s: move: %-18s %s \n\t from %-18s %s", __func__, - cbl_field_type_str(tgt.field->type) + 3, field_str(tgt.field), - cbl_field_type_str(from->type) + 3, from_str); - } return true; } return true; - } typedef std::pair<cbl_field_t*,cbl_field_t*> field_span_t; typedef std::pair<size_t, size_t> cbl_bytespan_t; -static void -dump_spans( size_t isym, - const cbl_field_t *table, - const std::list<field_span_t>& spans, - size_t nrange, - const cbl_bytespan_t ranges[], - size_t depth, - const std::list<cbl_subtable_t>& subtables ) -{ - int i=0; - assert( nrange == 0 || nrange == spans.size() ); - - if( isym != field_index(table) ) { - dbgmsg("%s:%d: isym %zu is not #%zu %02u %s", __func__, __LINE__, - isym, field_index(table), table->level, table->name); - } - dbgmsg( "%s: [%zu] #%zu %s has %zu spans and %zu subtables", - __func__, depth, isym, table->name, nrange, subtables.size() ); - for( auto span : spans ) { - unsigned int last_level = 0; - const char *last_name = "<none>"; - if( span.second ) { - last_level = span.second->level; - last_name = span.second->name; - } - - char at_subtable[64] = {}; - size_t offset = nrange? ranges[i].first : 0; - auto p = std::find_if(subtables.begin(), subtables.end(), - [offset]( const cbl_subtable_t& tbl ) { - return tbl.offset == offset; - }); - if( p != subtables.end() ) { - sprintf(at_subtable, "(subtable #%zu)", p->isym); - } - dbgmsg("\t %02u %-20s to %02u %-20s: %3zu-%zu %s", - span.first->level, span.first->name, - last_level, last_name, - nrange? ranges[i].first : 1, - nrange? ranges[i].second : 0, - at_subtable); - i++; - } - if( ! subtables.empty() ) { - dbgmsg("\ttable #%zu has %zu subtables", isym, subtables.size()); - for( auto tbl : subtables ) { - dbgmsg("\t #%zu @ %4zu", tbl.isym, tbl.offset); - } - } -} - /* * 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 ) { - if( getenv("initialize_statement") ) { - dbgmsg("%s:%d: %s ", __func__, __LINE__, target.refer.str()); - } - 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 ); @@ -12358,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; } @@ -12378,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; } } @@ -12391,14 +12641,8 @@ initialize_statement( const cbl_num_result_t& target, bool with_filler, const category_map_t& replacements, size_t depth = 0 ) { - if( getenv(__func__) ) { - dbgmsg("%s:%d: %2zu: %s (%s%zuR)", - __func__, __LINE__, depth, target.refer.str(), - with_filler? "F" : "", - replacements.size()); - } 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 ) { @@ -12435,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; @@ -12480,10 +12724,6 @@ initialize_statement( const cbl_num_result_t& target, bool with_filler, return std::make_pair(first, second); } ); } - if( getenv("initialize_statement") ) { - dump_spans( field_index(output.refer.field), output.refer.field, - field_spans, ranges.size(), ranges.data(), depth, subtables ); - } return initialize_table( output, nrange, ranges.data(), subtables ); } } @@ -12550,29 +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) { - if( yydebug && getenv(__func__) ) { - yywarn( "%s: %zu targets, %s filler", - __func__, tgts.size(), with_filler? "with" : "no"); - for( auto tgt : tgts ) { - fprintf( stderr, "%28s: %s\n", __func__, name_of(tgt.refer.field) ); - } - for( const auto& elem : replacements ) { - fprintf( stderr, "%28s: %s <-%s\n", __func__, - data_category_str(elem.first), - name_of(elem.second->field) ); - } - } - - 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 ); } @@ -12581,13 +12799,13 @@ initialize_statement( std::list<cbl_num_result_t>& tgts, bool with_filler, static void dump_inspect_oper( const cbl_inspect_oper_t& op ) { - dbgmsg("\t%s: %zu \"matches\", %zu \"replaces\"", - bound_str(op.bound), - op.matches? op.n_identifier_3 : 0, op.replaces? 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); + dbgmsg("\t%s: " HOST_SIZE_T_PRINT_UNSIGNED + " \"matches\", " HOST_SIZE_T_PRINT_UNSIGNED " \"replaces\"", + 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 @@ -12604,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 ) @@ -12636,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& @@ -12671,10 +12889,11 @@ cbl_field_t * new_literal( const literal_t& lit, enum cbl_field_attr_t attr ) { bool zstring = lit.prefix[0] == 'Z'; if( !zstring && lit.data[lit.len] != '\0' ) { - dbgmsg("%s:%d: line %d, no NUL terminator '%-*.*s'{%zu/%zu}", + dbgmsg("%s:%d: line %d, no NUL terminator '%-*.*s'{" + HOST_SIZE_T_PRINT_UNSIGNED "/" HOST_SIZE_T_PRINT_UNSIGNED "}", __func__, __LINE__, yylineno, int(lit.len), int(lit.len), - lit.data, strlen(lit.data), lit.len); + lit.data, (fmt_size_t)strlen(lit.data), (fmt_size_t)lit.len); } assert(zstring || lit.data[lit.len] == '\0'); @@ -12707,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 ) { @@ -12754,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)) { @@ -12780,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; } @@ -12812,15 +13059,27 @@ mode_syntax_only( cbl_division_t division ) { bool mode_syntax_only() { return cbl_syntax_only != not_syntax_only - && cbl_syntax_only <= current_division; + && cbl_syntax_only <= current_division; } 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; @@ -12878,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, @@ -12901,30 +13160,34 @@ 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"; - sprintf(ub, " to %lu", oob->occurs.bounds.upper); + sprintf(ub, " to " HOST_SIZE_T_PRINT_UNSIGNED, + (fmt_size_t)oob->occurs.bounds.upper); upper_phrase = ub; } // 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; @@ -12946,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; @@ -12962,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; @@ -12970,6 +13233,17 @@ require_numeric( YYLTYPE loc, cbl_refer_t scalar ) { return true; } +static bool +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", + scalar.field->pretty_name()); + return false; + } + } + return require_numeric(loc, scalar); +} /* eval methods */ eval_subject_t::eval_subject_t() @@ -12987,7 +13261,8 @@ eval_subject_t::label( const char skel[] ) { cbl_label_t label = protolabel; label.line = yylineno; size_t n = 1 + symbols_end() - symbols_begin(); - snprintf(label.name, sizeof(label.name), "_eval_%s_%zu", skel, n); + snprintf(label.name, sizeof(label.name), + "_eval_%s_" HOST_SIZE_T_PRINT_UNSIGNED, skel, (fmt_size_t)n); auto output = symbol_label_add( PROGRAM, &label ); return output; } diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h index aa36628..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,42 +70,46 @@ 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; static size_t nparse_error = 0; -size_t parse_error_inc() { return ++nparse_error; } +size_t parse_error_inc() { + mode_syntax_only(current_division); + return ++nparse_error; +} size_t parse_error_count() { return nparse_error; } void input_file_status_notify(); -#define YYLLOC_DEFAULT(Current, Rhs, N) \ - do { \ - if (N) \ - { \ - (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \ - (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \ - (Current).last_line = YYRHSLOC (Rhs, N).last_line; \ - (Current).last_column = YYRHSLOC (Rhs, N).last_column; \ - location_dump("parse.c", N, \ - "rhs N ", YYRHSLOC (Rhs, N)); \ - } \ - else \ - { \ - (Current).first_line = \ - (Current).last_line = YYRHSLOC (Rhs, 0).last_line; \ - (Current).first_column = \ - (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(); \ +#define YYLLOC_DEFAULT(Current, Rhs, N) \ + do { \ + if (N) \ + { \ + (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \ + (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \ + (Current).last_line = YYRHSLOC (Rhs, N).last_line; \ + (Current).last_column = YYRHSLOC (Rhs, N).last_column; \ + location_dump("parse.c", N, \ + "rhs N ", YYRHSLOC (Rhs, N)); \ + } \ + else \ + { \ + (Current).first_line = \ + (Current).last_line = YYRHSLOC (Rhs, 0).last_line; \ + (Current).first_column = \ + (Current).last_column = YYRHSLOC (Rhs, 0).last_column; \ + } \ + location_dump("parse.c", __LINE__, "current", (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[] ) { @@ -131,8 +132,6 @@ const char * original_picture(); static const relop_t invalid_relop = static_cast<relop_t>(-1); -static enum cbl_division_t current_division; - static cbl_refer_t null_reference; static cbl_field_t *literally_one, *literally_zero; @@ -142,7 +141,8 @@ literal_of( size_t value ) { case 0: return literally_zero; case 1: return literally_one; } - cbl_err("logic error: %s: %zu not supported", __func__, value); + cbl_err("logic error: %s: " HOST_SIZE_T_PRINT_UNSIGNED " not supported", + __func__, (fmt_size_t)value); return NULL; } @@ -180,21 +180,23 @@ has_clause( int data_clauses, data_clause_t clause ) { return clause == (data_clauses & clause); } + static bool -is_cobol_word( const char name[] ) { +is_cobol_charset( const char name[] ) { auto eoname = name + strlen(name); - auto p = std::find_if( name, eoname, + auto ok = std::all_of( name, eoname, []( char ch ) { switch(ch) { case '-': case '_': - return false; + return true; case '$': // maybe one day (IBM allows) + return false; break; } - return !ISALNUM(ch); + return 0 != ISALNUM(ch); } ); - return p == eoname; + return ok; } bool @@ -208,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) @@ -221,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 ) { @@ -236,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_numeric( 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 ); @@ -281,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) @@ -312,21 +323,22 @@ struct evaluate_elem_t { case_iter pcase; void dump() const { - dbgmsg( "nother=%zu label '%s', %zu cases", nother, label.name, cases.size() ); + dbgmsg( "nother=" HOST_SIZE_T_PRINT_UNSIGNED " label '%s', " + HOST_SIZE_T_PRINT_UNSIGNED " cases", + (fmt_size_t)nother, label.name, (fmt_size_t)cases.size() ); std::for_each( cases.begin(), cases.end(), case_t::Dump ); } 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); } } @@ -357,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; @@ -379,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; @@ -428,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; } @@ -438,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; @@ -456,11 +470,12 @@ static class file_start_args_t { cbl_file_t *file; public: file_start_args_t() : file(NULL) {} - void init( YYLTYPE loc, cbl_file_t *file ) { + cbl_file_t * init( YYLTYPE loc, cbl_file_t *file ) { this->file = file; if( is_sequential(file) ) { error_msg(loc, "START invalid with sequential file %s", file->name); } + return file; } bool ready() const { return file != NULL; } void call_parser_file_start() { @@ -476,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); @@ -524,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 ); @@ -542,8 +558,10 @@ struct arith_t { res.refer.field = cbl_field_of(symbol_at(tgt)); tgts.push_back( res ); - dbgmsg("%s:%d: SRC: %3zu %s", __func__, __LINE__, src, a.str()); - dbgmsg("%s:%d: to %3zu %s", __func__, __LINE__, tgt, res.refer.str()); + dbgmsg("%s:%d: SRC: %3" GCC_PRISZ "u %s", + __func__, __LINE__, (fmt_size_t)src, a.str()); + dbgmsg("%s:%d: to %3" GCC_PRISZ "u %s", + __func__, __LINE__, (fmt_size_t)tgt, res.refer.str()); } void operator()( const corresponding_fields_t::const_reference elem ) { another_pair( elem.first, elem.second ); @@ -606,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(); } @@ -737,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; @@ -776,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()); @@ -879,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); } @@ -918,55 +936,78 @@ teed_up_names() { } class tokenset_t { - std::vector<const char *>token_names; - std::map <std::string, int> tokens; - std::set<std::string> cobol_words; - + // token_names is initialized from a generated header file. + std::vector<const char *>token_names; // position indicates token value + std::map <std::string, int> tokens; // aliases + std::set<std::string> cobol_words; // Anything in COBOL-WORDS may appear only once. + public: static std::string lowercase( const cbl_name_t name ) { cbl_name_t lname; std::transform(name, name + strlen(name) + 1, lname, ftolower); return lname; } + static std::string + uppercase( const cbl_name_t name ) { + cbl_name_t uname; + std::transform(name, name + strlen(name) + 1, uname, ftoupper); + return uname; + } public: tokenset_t(); int find( const cbl_name_t name, bool include_intrinsics ); - bool equate( const YYLTYPE& loc, int token, const cbl_name_t name ) { + bool equate( const YYLTYPE& loc, int token, + const cbl_name_t name, const cbl_name_t verb = "EQUATE") { auto lname( lowercase(name) ); auto cw = cobol_words.insert(lname); if( ! cw.second ) { - error_msg(loc, "COBOL-WORDS EQUATE: %s may appear but once", name); + error_msg(loc, "COBOL-WORDS %s: %s may appear but once", verb, name); return false; } auto p = tokens.find(lowercase(name)); bool fOK = p == tokens.end(); if( fOK ) { // name not already in use tokens[lname] = token; + dbgmsg("%s:%d: %d has alias %s", __func__, __LINE__, token, name); } else { - error_msg(loc, "EQUATE: %s already defined as a token", name); + error_msg(loc, "%s: %s already defined as a token", verb, name); } return fOK; } - bool undefine( const YYLTYPE& loc, const cbl_name_t name ) { + bool undefine( const YYLTYPE& loc, + const cbl_name_t name, const cbl_name_t verb = "UNDEFINE" ) { auto lname( lowercase(name) ); auto cw = cobol_words.insert(lname); if( ! cw.second ) { - error_msg(loc, "COBOL-WORDS UNDEFINE: %s may appear but once", name); + error_msg(loc, "COBOL-WORDS %s: %s may appear but once", verb, name); return false; } + + // Do not erase generic, multi-type tokens COMPUTATIONAL and BINARY_INTEGER. + if( binary_integer_usage_of(name) ) { + dbgmsg("%s:%d: generic %s remains valid as a token", __func__, __LINE__, name); + return true; + } + auto p = tokens.find(lname); bool fOK = p != tokens.end(); if( fOK ) { // name in use tokens.erase(p); } else { - error_msg(loc, "UNDEFINE: %s not defined as a token", name); + error_msg(loc, "%s: %s not defined as a token", verb, name); } + dbgmsg("%s:%d: %s removed as a valid token name", __func__, __LINE__, name); return fOK; } - bool substitute( const YYLTYPE& loc, const cbl_name_t extant, int token, const cbl_name_t name ) { - return equate( loc, token, name ) && undefine( loc, extant ); + + bool substitute( const YYLTYPE& loc, + const cbl_name_t extant, int token, const cbl_name_t name ) { + return + equate( loc, token, name, "SUBSTITUTE" ) + && + undefine( loc, extant, "SUBSTITUTE" ); } bool reserve( const YYLTYPE& loc, const cbl_name_t name ) { auto lname( lowercase(name) ); @@ -991,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]; } }; @@ -1002,24 +1043,42 @@ 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 name ) { - int token = keyword_tok(keyword); - if( 0 == token ) { - error_msg(loc, "EQUATE %s: not a valid token", keyword); - return false; + bool equate( const YYLTYPE& loc, const cbl_name_t keyword, const cbl_name_t alias ) { + int token; + if( 0 == (token = binary_integer_usage_of(keyword)) ) { + if( 0 == (token = keyword_tok(keyword)) ) { + error_msg(loc, "EQUATE %s: not a valid token", keyword); + return false; + } } - return tokens.equate(loc, token, name); + auto name = keyword_alias_add(tokens.uppercase(keyword), + tokens.uppercase(alias)); + if( name != keyword ) { + error_msg(loc, "EQUATE: %s is already an alias for %s", alias, name.c_str()); + return false; + } + return tokens.equate(loc, token, alias); } bool undefine( const YYLTYPE& loc, cbl_name_t keyword ) { return tokens.undefine(loc, keyword); } - bool substitute( const YYLTYPE& loc, cbl_name_t keyword, const cbl_name_t name ) { - int token = keyword_tok(keyword); - if( 0 == token ) { - error_msg(loc, "SUBSTITUTE %s: not a valid token", keyword); - return false; + bool substitute( const YYLTYPE& loc, const cbl_name_t keyword, const cbl_name_t alias ) { + int token; + if( 0 == (token = binary_integer_usage_of(keyword)) ) { + if( 0 == (token = keyword_tok(keyword)) ) { + error_msg(loc, "SUBSTITUTE %s: not a valid token", keyword); + return false; + } } - return tokens.substitute(loc, keyword, token, name); + auto name = keyword_alias_add(tokens.uppercase(keyword), + tokens.uppercase(alias)); + if( name != keyword ) { + error_msg(loc, "SUBSTITUTE: %s is already an alias for %s", alias, name.c_str()); + return false; + } + + dbgmsg("%s:%d: %s (%d) will have alias %s", __func__, __LINE__, keyword, token, alias); + return tokens.substitute(loc, keyword, token, alias); } bool reserve( const YYLTYPE& loc, const cbl_name_t name ) { return tokens.reserve(loc, name); @@ -1040,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()) { @@ -1054,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 ** @@ -1084,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; @@ -1106,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) @@ -1132,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 ); } @@ -1158,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() { @@ -1224,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) @@ -1248,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; } @@ -1270,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) @@ -1286,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); } @@ -1362,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(); } }; @@ -1378,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(); } @@ -1406,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; } }; @@ -1425,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); @@ -1441,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) @@ -1554,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); } @@ -1592,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; @@ -1604,6 +1641,7 @@ class program_stack_t : protected std::stack<prog_descr_t> { } return eval; } + // cppcheck-suppress-end useStlAlgorithm }; struct rel_part_t { @@ -1611,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), @@ -1647,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)); @@ -1706,18 +1748,11 @@ static class current_t { int first_statement; bool in_declaratives; // from command line or early TURN - std::list<cbl_exception_files_t> cobol_exceptions; + std::list<exception_turn_t> exception_turns; error_labels_t error_labels; static void declarative_execute( cbl_label_t *eval ) { - if( !eval ) { - if( !enabled_exceptions.empty() ) { - auto index = new_temporary(FldNumericBin5); - parser_match_exception(index, NULL); - } - return; - } assert(eval); auto iprog = symbol_elem_of(eval)->program; if( iprog == current_program_index() ) { @@ -1813,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; @@ -1820,6 +1859,13 @@ 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 { return declaratives_list_t::empty(); } @@ -1837,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", @@ -1849,14 +1895,46 @@ static class current_t { declaratives_list_t::push_back(declarative); return true; } + + // cppcheck-suppress-begin useStlAlgorithm + uint32_t status() const { + uint32_t status_word = 0; + for( auto dcl : *this ) { + status_word |= (EC_ALL_E & dcl.type ); + } + return status_word; + } + // cppcheck-suppress-end useStlAlgorithm + + bool has_format_1() const { + return std::any_of( begin(), end(), + []( const cbl_declarative_t& dcl ) { + return dcl.is_format_1(); + } ); + } + + std::vector<uint64_t> + encode() const { + std::vector<uint64_t> encoded; + auto p = std::back_inserter(encoded); + for( const auto& dcl : *this ) { + *p++ = dcl.section; + *p++ = dcl.global; + *p++ = dcl.type; + *p++ = dcl.nfile; + p = std::copy(dcl.files, std::end(dcl.files), p); + *p++ = dcl.mode; + } + return encoded; + } + } declaratives; void exception_add( ec_type_t ec, bool enabled = true) { - std::set<size_t> files; - enabled_exceptions.turn_on_off(enabled, - false, // for now - ec, files); - if( yydebug) enabled_exceptions.dump(); + exception_turns.push_back(exception_turn_t(ec, enabled)); + } + std::list<exception_turn_t>& pending_exceptions() { + return exception_turns; } bool typedef_add( const cbl_field_t *field ) { @@ -1866,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 ) { @@ -1922,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 @@ -1998,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(); @@ -2022,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)); @@ -2039,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; @@ -2061,12 +2138,12 @@ static class current_t { */ std::set<std::string> end_program() { if( enabled_exceptions.size() ) { - declaratives_evaluate(ec_none_e); + declaratives_evaluate(); } assert(!programs.empty()); - procref_t *ref = ambiguous_reference(program_index()); + const procref_t *ref = ambiguous_reference(program_index()); std::set<std::string> externals = programs.top().external_targets(); /* @@ -2077,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)); @@ -2087,11 +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 %zu calls from #%-3zu (%s) s/%s/%s/", - n, caller, caller_name, called->name, mangled_name); + 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(); } @@ -2121,7 +2213,7 @@ static class current_t { return symbol_index(symbol_elem_of(section)); } - cbl_label_t *doing_declaratives( bool begin ) { + cbl_label_t * doing_declaratives( bool begin ) { if( begin ) { in_declaratives = true; return NULL; @@ -2131,24 +2223,27 @@ static class current_t { if( declaratives.empty() ) return NULL; assert(!declaratives.empty()); - size_t idcl = symbol_declaratives_add(program_index(), declaratives.as_list()); - programs.top().declaratives_index = idcl; + declaratives.runtime.dcl = parser_compile_dcls(declaratives.encode()); // 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; } @@ -2156,14 +2251,32 @@ static class current_t { std::swap( programs.top().section, section ); return section; } + + ec_type_t ec_type_of( file_status_t status ) { + static std::vector<ec_type_t> ec_by_status { + /* 0 */ ec_none_e, // ec_io_warning_e if low byte is nonzero + /* 1 */ ec_io_at_end_e, + /* 2 */ ec_io_invalid_key_e, + /* 3 */ ec_io_permanent_error_e, + /* 4 */ ec_io_logic_error_e, + /* 5 */ ec_io_record_operation_e, + /* 6 */ ec_io_file_sharing_e, + /* 7 */ ec_io_record_content_e, + /* 8 */ ec_io_imp_e, // unused, not defined by ISO + /* 9 */ ec_io_imp_e, + }; + int status10 = static_cast<unsigned int>(status) / 10; + gcc_assert(ec_by_status.size() == 10); + gcc_assert(0 <= status10 && status10 < 10 && status10 != 8); + return ec_by_status[status10]; + } /* * 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. @@ -2173,18 +2286,8 @@ static class current_t { * alternative entry point (TODO). */ void - declaratives_evaluate( cbl_file_t *file, - file_status_t status = FsSuccess ) { - // The exception file number is assumed to be zero at all times unless - // it has been set to non-zero, at which point whoever picks it up and takes - // action on it is charged with setting it back to zero. - if( file ) - { - parser_set_file_number((int)symbol_index(symbol_elem_of(file))); - } - // parser_set_file_number(file ? (int)symbol_index(symbol_elem_of(file)) : 0); - parser_set_handled((ec_type_t)status); - + declaratives_evaluate( cbl_file_t *file ) { + gcc_assert(file); parser_file_stash(file); cbl_label_t *eval = programs.first_declarative(); @@ -2212,7 +2315,7 @@ static class current_t { * To indicate to the runtime-match function that we want to evaluate * only the exception condition, unrelated to a file, we set the * file register to 0 and the handled-exception register to the - * handled exception condition (not file status). + * handled exception condition. * * declaratives_execute performs the "declarative ladder" produced * by declaratives_runtime_match. That section CALLs the @@ -2223,16 +2326,9 @@ static class current_t { * index, per usual. */ void - declaratives_evaluate( ec_type_t handled = ec_none_e ) { - // The exception file number is assumed to be zero unless it has been - // changed to a non-zero value. The program picking it up and referencing - // it is charged with setting it back to zero. - // parser_set_file_number(0); - - parser_set_handled(handled); - + declaratives_evaluate() { cbl_label_t *eval = programs.first_declarative(); - declarative_execute(eval); + if( eval ) declarative_execute(eval); } cbl_label_t * new_paragraph( cbl_label_t *para ) { @@ -2276,15 +2372,20 @@ static class current_t { cbl_label_t * compute_label() { return error_labels.compute_error; } } current; +void current_enabled_ecs( tree ena ) { + current.declaratives.runtime.ena = ena; +} + #define PROGRAM current.program_index() 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; @@ -2354,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 ); @@ -2375,11 +2480,27 @@ literal_refmod_valid( YYLTYPE loc, const cbl_refer_t& r ); static bool is_integer_literal( const cbl_field_t *field ) { - if( is_literal(field) ) { - int v, n; + if( field->type == FldLiteralN ) { const char *initial = field->data.initial; - return 1 == sscanf(initial, "%d%n", &v, &n) && n == (int)strlen(initial); + switch( *initial ) { + case '-': case '+': ++initial; + } + + const char *eos = initial + strlen(initial); + auto p = std::find_if_not( initial, eos, fisdigit ); + if( p == eos ) return true; + + if( *p++ == symbol_decimal_point() ) { + switch( *p++ ) { + case 'E': case 'e': + switch( *p++ ) { + case '+': case '-': + return std::all_of(p, eos, []( char ch ) { return ch == '0'; } ); + break; + } + } + } } return false; } @@ -2453,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; } @@ -2500,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); @@ -2578,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 * @@ -3006,8 +3124,8 @@ file_add( YYLTYPE loc, cbl_file_t *file ) { } file = cbl_file_of(e); snprintf(field->name, sizeof(field->name), - "%s%zu_%s", - record_area_name_stem, symbol_index(e), file->name); + "%s" HOST_SIZE_T_PRINT_UNSIGNED "_%s", + record_area_name_stem, (fmt_size_t)symbol_index(e), file->name); if( file->attr & external_e ) { snprintf(field->name, sizeof(field->name), "%s%s", record_area_name_stem, file->name); @@ -3037,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); @@ -3048,15 +3177,30 @@ special_of( const char F[], int L, const char name[] ) { } #define special_of( F ) special_of(__func__, __LINE__, (F)) +static const special_name_t * +cmd_or_env_special_of( std::string name ) { + static const std::map< std::string, special_name_t > fujitsus + { // Fujitsu calls these "function names", not device names + { "ARGUMENT-NUMBER", ARG_NUM_e }, + { "ARGUMENT-VALUE", ARG_VALUE_e } , + { "ENVIRONMENT-NAME", ENV_NAME_e }, + { "ENVIRONMENT-VALUE", ENV_VALUE_e }, + }; + + std::transform(name.begin(), name.end(), name.begin(), ::toupper); + auto p = fujitsus.find(name.c_str()); + return p != fujitsus.end()? &p->second : nullptr; +} + 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); } @@ -3079,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]; @@ -3104,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); @@ -3140,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 ); @@ -3153,7 +3301,8 @@ static cbl_label_t * implicit_paragraph() { cbl_name_t name; - sprintf(name, "_implicit_paragraph_%zu", symbol_index()); + sprintf(name, "_implicit_paragraph_" HOST_SIZE_T_PRINT_UNSIGNED, + (fmt_size_t)symbol_index()); // Programs have to start with an implicit paragraph return label_add(LblParagraph, name, yylineno); } @@ -3161,12 +3310,14 @@ static cbl_label_t * implicit_section() { cbl_name_t name; - sprintf(name, "_implicit_section_%zu", symbol_index()); + sprintf(name, "_implicit_section_" HOST_SIZE_T_PRINT_UNSIGNED, + (fmt_size_t)symbol_index()); // Programs have to start with an implicit section return label_add(LblSection, name, yylineno); } static void +// cppcheck-suppress constParameterPointer ast_enter_exit_section( cbl_label_t * section ) { auto implicit = section? implicit_paragraph() : NULL; @@ -3236,7 +3387,8 @@ data_division_ready() { } if( nsymbol == 0 || nparse_error > 0 ) { - dbgmsg( "%d errors in DATA DIVISION, compilation ceases", nparse_error ); + dbgmsg( HOST_SIZE_T_PRINT_DEC " errors in DATA DIVISION, compilation ceases", + (fmt_size_t)nparse_error ); return false; } @@ -3245,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) @@ -3255,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; } @@ -3302,6 +3455,13 @@ procedure_division_ready( YYLTYPE loc, cbl_field_t *returning, ffi_args_t *ffi_a } } + // Apply ECs from the command line + std::list<exception_turn_t>& exception_turns = current.pending_exceptions(); + for( const auto& exception_turn : exception_turns) { + apply_cdf_turn(exception_turn); + } + exception_turns.clear(); + // Start the Procedure Division. size_t narg = ffi_args? ffi_args->elems.size() : 0; std::vector <cbl_ffi_arg_t> args(narg); @@ -3468,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, @@ -3534,6 +3694,11 @@ goodnight_gracie() { return true; } +// false after USE statement, to enter Declarative with EC intact. +static bool statement_cleanup = true; + +static void statement_epilog( int token ); + const char * keyword_str( int token ); static YYLTYPE current_location; @@ -3545,9 +3710,7 @@ location_set( const YYLTYPE& loc ) { return current_location = loc; } -static int prior_statement; - -static size_t statement_begin( const YYLTYPE& loc, int token ); +static void statement_begin( const YYLTYPE& loc, int token ); static void ast_first_statement( const YYLTYPE& loc ) { if( current.is_first_statement( loc ) ) { 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 2cb7d30..2fc4aea 100644 --- a/gcc/cobol/scan.l +++ b/gcc/cobol/scan.l @@ -27,6 +27,9 @@ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ +%top{ +#include "config.h" +} %{ #include <fstream> // Before cobol-system because it uses poisoned functions #include "cobol-system.h" @@ -76,6 +79,8 @@ nonseq (([''][[:alnum:]]+][''])|([""][[:alnum:]]+[""])) INTEGER 0*[1-9][[:digit:]]* INTEGERZ [[:digit:]]+ +NONWORD [^[:alnum:]$_-]+ + SPC [[:space:]]+ OSPC [[:space:]]* EOL \r?\n @@ -83,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} @@ -95,7 +100,6 @@ NP P+|(P{COUNT}) UNSIGNED [[:space:]]+UNSIGNED SIGNED [[:space:]]+SIGNED -DBLLONG (LONG-LONG|DOUBLE) ALNUM [AX9]+ @@ -174,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 @@ -268,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. @@ -324,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; } @@ -854,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; } @@ -973,24 +988,23 @@ USE({SPC}FOR)? { return USE; } COMP(UTATIONAL)? { return ucomputable(FldNumericBinary, 0); } BINARY { return scomputable(FldNumericBinary, 0); } - BINARY-CHAR{SIGNED} { return scomputable(FldNumericBin5, 1); } - BINARY-CHAR{UNSIGNED} { return ucomputable(FldNumericBin5, 1); } - BINARY-CHAR { return scomputable(FldNumericBin5, 1); } - BINARY-SHORT{SIGNED} { return scomputable(FldNumericBin5, 2); } - BINARY-SHORT{UNSIGNED} { return ucomputable(FldNumericBin5, 2); } - BINARY-SHORT { return scomputable(FldNumericBin5, 2); } - BINARY-LONG{SIGNED} { return scomputable(FldNumericBin5, 4); } - BINARY-LONG{UNSIGNED} { return ucomputable(FldNumericBin5, 4); } - BINARY-LONG { return scomputable(FldNumericBin5, 4); } - BINARY-{DBLLONG}{SIGNED} { return scomputable(FldNumericBin5, 8); } - BINARY-{DBLLONG}{UNSIGNED} { return ucomputable(FldNumericBin5, 8); } - BINARY-{DBLLONG} { return scomputable(FldNumericBin5, 8); } + BINARY-CHAR { return bcomputable(FldNumericBin5, 1); } + BINARY-SHORT { return bcomputable(FldNumericBin5, 2); } + BINARY-LONG { return bcomputable(FldNumericBin5, 4); } + BINARY-DOUBLE { return bcomputable(FldNumericBin5, 8); } + BINARY-LONG-LONG { if( ! dialect_mf() ) { + dialect_error(yylloc, yytext, "mf"); + } + return bcomputable(FldNumericBin5, 8); + } + BIT { not_implemented("USAGE type: BIT"); return BIT; } + 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 @@ -1000,6 +1014,9 @@ USE({SPC}FOR)? { return USE; } FLOAT-LONG { return ucomputable(FldFloat, 8); } FLOAT-SHORT { return ucomputable(FldFloat, 4); } + SIGNED { return SIGNED_kw; } + UNSIGNED { return UNSIGNED_kw; } + INDEX { return INDEX; } MESSAGE-TAG { not_implemented("USAGE type: MESSAGE-TAG"); } NATIONAL { not_implemented("USAGE type: NATIONAL"); @@ -1013,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 @@ -1114,10 +1131,14 @@ USE({SPC}FOR)? { return USE; } FD/[[:blank:]]+ { parsing.need_level(false); return FD; } SD/[[:blank:]]+ { parsing.need_level(false); return SD; } - {NAME} { // NAME here is never a token name + {NAME} { // NAME here might be a token alias + int token; + if( 0 != (token = binary_integer_usage(yytext)) ) { + return token; + } if( is_integer_token() ) return numstr_of(yytext); ydflval.string = yylval.string = xstrdup(yytext); - auto token = typed_name(yytext); + token = typed_name(yytext); return token == NAME88? NAME : token; } @@ -1201,6 +1222,11 @@ USE({SPC}FOR)? { return USE; } {N9}/{N9}*[,.]? { yylval.number = ndigit(yyleng); return picset(NINES); } P+/[,.]?\r?\n { yylval.number = yyleng; return picset(PIC_P); } + 1{1,31}/({COUNT}|[(]{NAME}[)]) { + yy_push_state(picture_count); + yylval.string = xstrdup(yytext); return picset(ONES); } + 1{1,31} { yylval.string = xstrdup(yytext); return picset(ONES); } + {ALNUM}/{COUNT}({ALNUM}{COUNT}?)+ { yy_push_state(picture_count); yylval.string = xstrdup(yytext); return picset(ALNUM); } @@ -1379,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); } @@ -1486,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; } @@ -1498,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; } @@ -1543,9 +1590,9 @@ USE({SPC}FOR)? { return USE; } NOT{SPC}(ON{SPC})?EXCEPTION { yylval.number = NOT; return EXCEPTION; } - (ON{SPC})?OVERFLOW { yylval.number = OVERFLOW; return OVERFLOW; } + (ON{SPC})?OVERFLOW { yylval.number = OVERFLOW_kw; return OVERFLOW_kw; } NOT{SPC}(ON{SPC})?OVERFLOW { - yylval.number = NOT; return OVERFLOW; } + yylval.number = NOT; return OVERFLOW_kw; } (AT{SPC})?END/[[:space:]] { yylval.number = END; return END; } @@ -1571,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; } @@ -1599,26 +1647,14 @@ 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 = keyword_tok(yylval.string); - if( token ) return token; - if( is_integer_token() ) return numstr_of(yylval.string); - return typed_name(yylval.string); } {NAME}/{OSPC}{DOTSEP} { assert(YY_START == procedure_div); - int token = keyword_tok(yytext); - if( token ) return token; + int token; + if( 0 != (token = binary_integer_usage(yytext)) ) return token; + if( 0 != (token = keyword_tok(yytext)) ) return token; if( is_integer_token() ) return numstr_of(yytext); ydflval.string = yylval.string = xstrdup(yytext); @@ -1780,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)); @@ -1994,7 +2032,7 @@ BASIS { yy_push_state(basis); return BASIS; } } return token; } - [.][[:blank:].]+ { return '.'; } + [.]+[[:blank:].]+ { return '.'; } } <exception>{ @@ -2092,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 @@ -2135,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; } @@ -2187,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; } @@ -2206,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; } @@ -2229,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; } + 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; } @@ -2331,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; } @@ -2353,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; } @@ -2374,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; } } <*>{ @@ -2460,28 +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); - 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); - } + return NO_CONDITION; + } +} %% diff --git a/gcc/cobol/scan_ante.h b/gcc/cobol/scan_ante.h index b9bbd30..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; @@ -438,11 +478,12 @@ trim_location( int nkeep) { } rescan = { yytext + nkeep, yytext + yyleng }; auto nline = std::count(rescan.p, rescan.pend, '\n'); - dbgmsg("%s:%d: yyless(%d), rescan '%.*s' (%zu lines, %d bytes)", + dbgmsg("%s:%d: yyless(%d), rescan '%.*s' (" HOST_SIZE_T_PRINT_UNSIGNED + " lines, " HOST_SIZE_T_PRINT_UNSIGNED " bytes)", __func__, __LINE__, nkeep, int(rescan.size()), rescan.p, - nline, rescan.size()); + (fmt_size_t)nline, (fmt_size_t)rescan.size()); if( nline ) { gcc_assert( yylloc.first_line + nline <= yylloc.last_line ); yylloc.last_line =- int(nline); @@ -473,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) /* @@ -482,21 +524,21 @@ 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)) ) \ result = YY_NULL; \ } +#define bcomputable(T, C) \ + yylval.computational.type=T, \ + yylval.computational.capacity=C, \ + yylval.computational.signable=true, BINARY_INTEGER #define scomputable(T, C) \ yylval.computational.type=T, \ yylval.computational.capacity=C, \ @@ -510,6 +552,110 @@ static char *tmpstring = NULL; #define PROGRAM current_program_index() +// map of alias => canonical +static std::map <std::string, std::string> keyword_aliases; + +const std::string& +keyword_alias_add( const std::string& keyword, const std::string& alias ) { + auto p = keyword_aliases.find(alias); + if( p != keyword_aliases.end() ) return p->second; // error: do not overwrite + return keyword_aliases[alias] = keyword; +} + +/* + * Because numeric USAGE types don't have distinct tokens and may have aliases, + * we keep a table of their canonical names, which we use if we encounter an + * alias. + */ +struct bint_t { + int token; + cbl_field_type_t type; + uint32_t capacity; + bool signable; +}; +static const std::map <std::string, bint_t > binary_integers { + { "COMP-X", { COMPUTATIONAL, FldNumericBin5, 0xFF, false } }, + { "COMP-6", { COMPUTATIONAL, FldPacked, 0, false } }, + { "COMP-5", { COMPUTATIONAL, FldNumericBin5, 0, false } }, + { "COMP-4", { COMPUTATIONAL, FldNumericBinary, 0, true } }, + { "COMP-2", { COMPUTATIONAL, FldFloat, 8, false } }, + { "COMP-1", { COMPUTATIONAL, FldFloat, 4, false } }, + { "COMP", { COMPUTATIONAL, FldNumericBinary, 0, false } }, + { "COMPUTATIONAL-X", { COMPUTATIONAL, FldNumericBin5, 0xFF, false } }, + { "COMPUTATIONAL-6", { COMPUTATIONAL, FldPacked, 0, false } }, + { "COMPUTATIONAL-5", { COMPUTATIONAL, FldNumericBin5, 0, false } }, + { "COMPUTATIONAL-4", { COMPUTATIONAL, FldNumericBinary, 0, true } }, + { "COMPUTATIONAL-2", { COMPUTATIONAL, FldFloat, 8, false } }, + { "COMPUTATIONAL-1", { COMPUTATIONAL, FldFloat, 4, false } }, + { "COMPUTATIONAL", { COMPUTATIONAL, FldNumericBinary, 0, false } }, + { "BINARY", { BINARY_INTEGER, FldNumericBinary, 0, true } }, + { "BINARY-CHAR", { BINARY_INTEGER, FldNumericBin5, 1, true } }, + { "BINARY-SHORT", { BINARY_INTEGER, FldNumericBin5, 2, true } }, + { "BINARY-LONG", { BINARY_INTEGER, FldNumericBin5, 4, true } }, + { "BINARY-DOUBLE", { BINARY_INTEGER, FldNumericBin5, 8, true } }, + { "BINARY-LONG-LONG", { BINARY_INTEGER, FldNumericBin5, 8, true } }, + { "FLOAT-BINARY-32", { COMPUTATIONAL, FldFloat, 4, false } }, + { "FLOAT-BINARY-64", { COMPUTATIONAL, FldFloat, 8, false } }, + { "FLOAT-BINARY-128", { COMPUTATIONAL, FldFloat, 16, false } }, + { "FLOAT-EXTENDED", { COMPUTATIONAL, FldFloat, 16, false } }, + { "FLOAT-LONG", { COMPUTATIONAL, FldFloat, 8, false } }, + { "FLOAT-SHORT", { COMPUTATIONAL, FldFloat, 4, false } }, +}; + +static int +binary_integer_usage( const char name[]) { + cbl_name_t uname = {}; + std::transform(name, name + strlen(name), uname, ftoupper); + + dbgmsg("%s:%d: checking %s in %zu keyword_aliases", + __func__, __LINE__, uname, + keyword_aliases.size() ); + + std::string key = uname; + auto alias = keyword_aliases.find(key); + if( alias != keyword_aliases.end() ) key = alias->second; + + auto p = binary_integers.find(key); + if( p == binary_integers.end() ) return 0; + + yylval.computational.type = p->second.type; + yylval.computational.capacity = p->second.capacity; + yylval.computational.signable = p->second.signable; + dbgmsg("%s:%d: %s has type %d", __func__, __LINE__, + uname, p->second.type ); + 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 = {}; + std::transform(name, name + strlen(name), uname, ftoupper); + + auto p = binary_integers.find(uname); + if( p != binary_integers.end() ) { + int token = p->second.token; + switch( token ) { + case COMPUTATIONAL: + case BINARY_INTEGER: + return token; + default: + gcc_unreachable(); + assert(false); + } + } + return 0; +} + static uint32_t level_of( const char input[] ) { unsigned int output = 0; @@ -559,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; } @@ -633,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); @@ -643,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; @@ -677,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; } @@ -694,40 +844,11 @@ tmpstring_append( int len ) { const char *extant = tmpstring == NULL ? "" : tmpstring; char *s = xasprintf("%s%.*s", extant, len, yytext); free(tmpstring); - if( yy_flex_debug && getenv(__func__) ) { - yywarn("%s: value is now '%s'", __func__, s); - } return tmpstring = s; } #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 dabb168..a273da9 100644 --- a/gcc/cobol/scan_post.h +++ b/gcc/cobol/scan_post.h @@ -33,13 +33,15 @@ start_condition_str( int sc ) { const char *state = "???"; switch(sc) { case INITIAL: state = "INITIAL"; break; + case addr_of: state = "addr_of"; break; case author_state: state = "author_state"; break; case basis: state = "basis"; break; case bool_state: state = "bool_state"; break; case cdf_state: state = "cdf_state"; break; case classify: state = "classify"; break; - case copy_state: state = "copy_state"; break; + case cobol_words: state = "cobol_words"; break; case comment_entries: state = "comment_entries"; break; + case copy_state: state = "copy_state"; break; case date_state: state = "date_state"; break; case datetime_fmt: state = "datetime_fmt"; break; case dot_state: state = "dot_state"; break; @@ -62,8 +64,8 @@ start_condition_str( int sc ) { case quoted2: state = "quoted2"; break; case quoteq: state = "quoteq"; break; case raising: state = "raising"; break; - case subscripts: state = "subscripts"; break; case sort_state: state = "sort_state"; break; + case subscripts: state = "subscripts"; break; } return state; } @@ -114,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); } @@ -258,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. @@ -296,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; @@ -373,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 ad26584..db24807 100644 --- a/gcc/cobol/show_parse.h +++ b/gcc/cobol/show_parse.h @@ -42,9 +42,6 @@ // SHOW_PARSE must be followed by a bracketed set of instructions, no semicolon -// This construction isn't really necessary; getenv() apparently runs pretty -// fast. But using makes compiling a large number of programs just perceptably -// quicker. So, I am using it; it's cheap. extern bool bSHOW_PARSE; extern bool show_parse_sol; extern int show_parse_indent; @@ -57,11 +54,20 @@ extern bool cursor_at_sol; #pragma GCC diagnostic push #pragma GCC diagnostic ignored "-Wmissing-field-initializers" +/* + * In syntax-only mode, return immediately. By using these macros, the parser + * can call code-generation functions unconditionally because it does not rely + * on the results. + */ #define RETURN_IF_PARSE_ONLY \ do { if( mode_syntax_only() ) return; } while(0) -#define SHOW_PARSE1 if(bSHOW_PARSE) -#define SHOW_PARSE RETURN_IF_PARSE_ONLY; if(bSHOW_PARSE) +#define RETURN_XX_PARSE_ONLY(XX) \ + do { if( mode_syntax_only() ) return XX; } while(0) + +#define SHOW_PARSE1 if(bSHOW_PARSE) +#define SHOW_PARSE RETURN_IF_PARSE_ONLY; if(bSHOW_PARSE) +#define SHOW_IF_PARSE(XX) RETURN_XX_PARSE_ONLY((XX)); if(bSHOW_PARSE) // _HEADER and _END are generally the first and last things inside the // SHOW_PARSE statement. They don't have to be; SHOW_PARSE can be used @@ -141,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) \ { \ @@ -331,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, " "); \ } \ @@ -418,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 @@ -500,7 +507,7 @@ class ANALYZE class ANALYZE { public: - ANALYZE(const char *) + explicit ANALYZE(const char *) { } ~ANALYZE() diff --git a/gcc/cobol/structs.cc b/gcc/cobol/structs.cc index e6f38e6..7a4db97 100644 --- a/gcc/cobol/structs.cc +++ b/gcc/cobol/structs.cc @@ -156,6 +156,7 @@ tree cblc_field_p_type_node; tree cblc_field_pp_type_node; tree cblc_file_type_node; tree cblc_file_p_type_node; +tree cbl_enabled_exception_type_node; tree cblc_goto_type_node; // The following functions return type_decl nodes for the various structures @@ -176,7 +177,7 @@ create_cblc_field_t() struct cblc_field_t *parent;// This field's immediate parent field size_t occurs_lower; // non-zero for a table size_t occurs_upper; // non-zero for a table - size_t attr; // See cbl_field_attr_t + uint64_t attr; // See cbl_field_attr_t signed char type; // A one-byte copy of cbl_field_type_t signed char level; // This variable's level in the naming heirarchy signed char digits; // Digits specified in PIC string; e.g. 5 for 99v999 @@ -196,7 +197,7 @@ create_cblc_field_t() CHAR_P, "parent", SIZE_T, "occurs_lower", SIZE_T, "occurs_upper", - SIZE_T, "attr", + ULONGLONG, "attr", SCHAR, "type", SCHAR, "level", SCHAR, "digits", @@ -216,6 +217,7 @@ create_cblc_file_t() typedef struct cblc_file_t { char *name; // This is the name of the structure; might be the name of an environment variable + size_t symbol_index; // The symbol table index of the related cbl_file_t structure char *filename; // The name of the file to be opened FILE *file_pointer; // The FILE *pointer cblc_field_t *default_record; // The record_area @@ -250,8 +252,9 @@ typedef struct cblc_file_t tree retval = NULL_TREE; retval = gg_get_filelevel_struct_type_decl( "cblc_file_t", - 30, + 31, CHAR_P, "name", + SIZE_T, "symbol_table_index", CHAR_P, "filename", FILE_P, "file_pointer", cblc_field_p_type_node, "default_record", @@ -285,6 +288,29 @@ typedef struct cblc_file_t return retval; } +static tree +create_cbl_enabled_exception_t() + { + /* + struct cbl_enabled_exception_t + { + bool enabled, location; + ec_type_t ec; + size_t file; + }; + */ + tree retval = NULL_TREE; + retval = gg_get_filelevel_struct_type_decl( "cbl_enabled_exception_t", + 4, + BOOL, "enabled", + BOOL, "location", + UINT, "ec", + SIZE_T, "file"); + retval = TREE_TYPE(retval); + + return retval; + } + void create_our_type_nodes() { @@ -297,6 +323,7 @@ create_our_type_nodes() cblc_field_pp_type_node = build_pointer_type(cblc_field_p_type_node); cblc_file_type_node = create_cblc_file_t(); cblc_file_p_type_node = build_pointer_type(cblc_file_type_node); + cbl_enabled_exception_type_node = create_cbl_enabled_exception_t(); } } diff --git a/gcc/cobol/structs.h b/gcc/cobol/structs.h index 47a78b4..1a16523 100644 --- a/gcc/cobol/structs.h +++ b/gcc/cobol/structs.h @@ -54,6 +54,7 @@ extern GTY(()) tree cblc_field_p_type_node; extern GTY(()) tree cblc_field_pp_type_node; extern GTY(()) tree cblc_file_type_node; extern GTY(()) tree cblc_file_p_type_node; +extern GTY(()) tree cbl_enabled_exception_type_node; extern GTY(()) tree cblc_goto_type_node; extern void create_our_type_nodes(); diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index 4067459..089c9c1 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -28,6 +28,7 @@ * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ +#include "config.h" #include <fstream> // Before cobol-system because it uses poisoned functions #include "cobol-system.h" @@ -55,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) {} @@ -135,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"); } @@ -159,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)); } /* @@ -228,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) @@ -256,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 @@ -316,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; @@ -369,12 +337,6 @@ special_pair_cmp( const cbl_special_name_t& key, const cbl_special_name_t& elem ) { const bool matched = key.id == elem.id || 0 == strcasecmp(key.name, elem.name); - if( getenv(__func__) ) { - dbgmsg("%s:%d: key: id=%2d, %s", __func__, __LINE__, key.id, key.name); - dbgmsg("%s:%d: elem: id=%2d, %s => %s", __func__, __LINE__, - elem.id, elem.name, matched? "match" : "no match"); - } - return matched; } @@ -492,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; @@ -820,24 +779,24 @@ cbl_field_t::size() const { return field_size(this); } -size_t +uint64_t cbl_field_t::set_attr( cbl_field_attr_t attr ) { if( attr == signable_e ) { if( ! has_attr(attr) && this->var_decl_node != NULL ) { parser_field_attr_set(this, attr); } } - return this->attr |= size_t(attr); + return this->attr |= uint64_t(attr); } -size_t +uint64_t cbl_field_t::clear_attr( cbl_field_attr_t attr ) { if( attr == signable_e ) { if( this->var_decl_node != nullptr && has_attr(attr) ) { parser_field_attr_set(this, attr, false); } } - return this->attr &= ~size_t(attr); + return this->attr &= ~uint64_t(attr); } static uint32_t @@ -893,13 +852,6 @@ update_block_offsets( struct symbol_elem_t *block) uint32_t offset = cbl_field_of(block)->offset; const uint32_t block_level = cbl_field_of(block)->level; - if( getenv(__func__) ) { - cbl_field_t *field = cbl_field_of(block); - dbgmsg( "%s: offset is %3zu for %2u %-30s #%3zu P%zu", - __func__, field->offset, field->level, field->name, - symbol_index(block), field->parent ); - } - struct symbol_elem_t *e = block; for( ++e; e < symbols_end(); e++ ) { if( e->type != SymField ) { @@ -929,12 +881,6 @@ update_block_offsets( struct symbol_elem_t *block) offset += field_memsize(field); } - if( getenv(__func__) ) { - dbgmsg( "%s: offset is %3zu for %2u %-30s #%3zu P%zu", - __func__, field->offset, field->level, field->name, - symbol_index(e), field->parent ); - } - if( field->type == FldGroup ) { e = update_block_offsets(e) - 1; } @@ -965,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)); @@ -985,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; @@ -996,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(); } @@ -1020,8 +966,8 @@ symbol_field_capacity( const cbl_field_t *field ) { size_t size = std::accumulate( symbol_at(bog), symbol_at_impl(eog), 0, sym_field_size::capacity ); - if(true) dbgmsg("%s: %02u %s.data.capacity was computed as %zu", __func__, - field->level, field->name, size); + if(true) dbgmsg("%s: %02u %s.data.capacity was computed as " HOST_SIZE_T_PRINT_UNSIGNED, + __func__, field->level, field->name, (fmt_size_t)size); return size; } @@ -1035,14 +981,15 @@ has_odo( const symbol_elem_t& e ) { struct cbl_field_t * symbol_find_odo_debug( cbl_field_t * field ) { size_t bog = field_index(field), eog = end_of_group(bog); - dbgmsg("%s: %s is #%zu - #%zu of %zu, ends at %s", __func__, - field->name, bog, eog, symbols.nelem, + dbgmsg("%s: %s is #" HOST_SIZE_T_PRINT_UNSIGNED " - #" HOST_SIZE_T_PRINT_UNSIGNED + " of " HOST_SIZE_T_PRINT_UNSIGNED ", ends at %s", __func__, + field->name, (fmt_size_t)bog, (fmt_size_t)eog, (fmt_size_t)symbols.nelem, eog == symbols.nelem? "[end]" : cbl_field_of(symbol_at(eog))->name ); auto e = std::find_if( symbol_at(bog), symbol_at_impl(eog, true), has_odo ); if( e != symbol_at_impl(eog, true) ) { - dbgmsg("%s: %s has ODO at #%zu (return '%s')", __func__, - field->name, symbol_index(e), + dbgmsg("%s: %s has ODO at #" HOST_SIZE_T_PRINT_UNSIGNED " (return '%s')", __func__, + field->name, (fmt_size_t)symbol_index(e), cbl_field_of(e)->name ); } return e == symbol_at_impl(eog, true)? NULL : cbl_field_of(e); @@ -1050,8 +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 ) { - if( getenv(__func__) ) return symbol_find_odo_debug(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); @@ -1067,8 +1013,8 @@ symbols_dump( size_t first, bool header ) { if( !yydebug ) return 0; if( header ) { - fprintf(stderr, "Symbol Table has %zu elements\n", - symbols_end() - symbols_begin()); + fprintf(stderr, "Symbol Table has " HOST_SIZE_T_PRINT_UNSIGNED " elements\n", + (fmt_size_t)(symbols_end() - symbols_begin())); } for( struct symbol_elem_t *e = symbols_begin(first); e < symbols_end(); e++ ) { @@ -1076,25 +1022,22 @@ symbols_dump( size_t first, bool header ) { switch(e->type) { case SymFilename: - s = xasprintf("%4zu %-18s %s", e->program, + s = xasprintf("%4" GCC_PRISZ "u %-18s %s", (fmt_size_t)e->program, "Filename", e->elem.filename); break; case SymDataSection: - s = xasprintf("%4zu %-18s line %d", e->program, + 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("%4zu %-15s %s", e->program, - "Function", e->elem.function.name); - break; case SymField: { auto field = cbl_field_of(e); char *odo_str = NULL; if( field->occurs.depending_on != 0 ) { - odo_str = xasprintf("odo %zu", field->occurs.depending_on ); + odo_str = xasprintf("odo " HOST_SIZE_T_PRINT_UNSIGNED, + (fmt_size_t)field->occurs.depending_on ); } ninvalid += cbl_field_of(e)->type == FldInvalid? 1 : 0; - s = xasprintf("%4zu %-18s %s (%s)", e->program, + s = xasprintf("%4" GCC_PRISZ "u %-18s %s (%s)", (fmt_size_t)e->program, cbl_field_type_str(cbl_field_of(e)->type) + 3, field_str(cbl_field_of(e)), odo_str? odo_str : @@ -1102,7 +1045,7 @@ symbols_dump( size_t first, bool header ) { } break; case SymLabel: - s = xasprintf("%4zu %-18s %s", e->program, + s = xasprintf("%4" GCC_PRISZ "u %-18s %s", (fmt_size_t)e->program, "Labe1l", e->elem.label.str()); if( LblProgram == cbl_label_of(e)->type ) { const auto& L = *cbl_label_of(e); @@ -1114,31 +1057,35 @@ symbols_dump( size_t first, bool header ) { } break; case SymSpecial: - s = xasprintf("%4zu %-18s id=%2d, %s", e->program, + s = xasprintf("%4" GCC_PRISZ "u %-18s id=%2d, %s", (fmt_size_t)e->program, "Special", e->elem.special.id, e->elem.special.name); break; case SymAlphabet: - s = xasprintf("%4zu %-18s encoding=%2d, '%s'", e->program, "Alphabet", + s = xasprintf("%4" GCC_PRISZ "u %-18s encoding=%2d, '%s'", + (fmt_size_t)e->program, "Alphabet", int(e->elem.alphabet.encoding), e->elem.alphabet.name); break; case SymFile: - s = xasprintf("%4zu %-18s %-20s", e->program, + s = xasprintf("%4" GCC_PRISZ "u %-18s %-20s", (fmt_size_t)e->program, "File", e->elem.file.name); { char same_as[26] = ""; if( cbl_file_of(e)->same_record_as > 0 ) { - sprintf(same_as, "s%3zu", cbl_file_of(e)->same_record_as); + sprintf(same_as, "s%3" GCC_PRISZ "u", + (fmt_size_t)cbl_file_of(e)->same_record_as); } const char *type = file_org_str(e->elem.file.org); char *part = s; - s = xasprintf("%s %-4s %s %s %s{%zu-%zu} status=#%zu", + s = xasprintf("%s %-4s %s %s %s{" HOST_SIZE_T_PRINT_UNSIGNED "-" + HOST_SIZE_T_PRINT_UNSIGNED "} status=#" + HOST_SIZE_T_PRINT_UNSIGNED, part, same_as, type, e->elem.file.keys_str(), cbl_file_of(e)->varies()? "varies " : "", - cbl_file_of(e)->varying_size.min, - cbl_file_of(e)->varying_size.max, - cbl_file_of(e)->user_status); + (fmt_size_t)cbl_file_of(e)->varying_size.min, + (fmt_size_t)cbl_file_of(e)->varying_size.max, + (fmt_size_t)cbl_file_of(e)->user_status); free(part); } break; @@ -1146,7 +1093,8 @@ symbols_dump( size_t first, bool header ) { dbgmsg("%s: cannot dump symbol type %d", __func__, e->type); continue; } - fprintf(stderr, "%4zu: %s\n", e - symbols_begin(), s); + fprintf(stderr, "%4" GCC_PRISZ "u: %s\n", + (fmt_size_t)(e - symbols_begin()), s); free(s); } return ninvalid; @@ -1226,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, @@ -1258,7 +1206,8 @@ static struct symbol_elem_t * } if(yydebug && group->type != FldGroup) { - dbgmsg("Field #%zu '%s' is not a group", symbol_index(e), group->name); + dbgmsg("Field #" HOST_SIZE_T_PRINT_UNSIGNED " '%s' is not a group", + (fmt_size_t)symbol_index(e), group->name); symbols_dump(symbols.first_program, true); } if( group->type == FldInvalid ) return e; @@ -1288,10 +1237,6 @@ static struct symbol_elem_t * // Print accumulating details for one group to debug log. bool details = false; - if( yydebug ) { - const auto details_for = getenv("symbols_update"); - details = details_for && 0 == strcasecmp(details_for, group->name); - } // At end of group, members is a list of all immediate children, any // of which might have been redefined and so acquired a memsize. @@ -1363,23 +1308,6 @@ verify_block( const struct symbol_elem_t *block, if( e->type != SymField ) { continue; } - const struct cbl_field_t *field = cbl_field_of(e); - - if( getenv(__func__) ) { - if( e == block ) { - static const char ds[] = "--------------------------------"; - dbgmsg( "%17s %-3s %-3s %-18s %-3s %3s %-16s C/D/R = init\n" - "%.25s %-.3s %-.3s %-.18s %-.3s %.3s %-.16s %-.7s %-.16s", - "", "ndx", "off", "type", "par", "lvl", "name", - ds, ds, ds, ds, ds, ds, ds, ds, ds ); - } - dbgmsg( "%s:%d: %3zu %3zu %-18s %3zu %02d %-16s %2u/%u/%d = '%s'", - __func__, __LINE__, e - symbols.elems, field->offset, - cbl_field_type_str(field->type), - field->parent, field->level, field->name, - field->data.capacity, field->data.digits, field->data.rdigits, - field->data.initial? field->data.initial : "(none)" ); - } } } @@ -1415,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; } @@ -1439,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)); @@ -1534,17 +1461,17 @@ field_str( const cbl_field_t *field ) { for( size_t i=0; i < field->occurs.nkey; i++ ) { updown[i] = field->occurs.keys[i].ascending? 'A' : 'D'; } - snprintf(name, sizeof(name), "%s[%zu]%s", - field->name, field->occurs.ntimes(), updown.data()); + snprintf(name, sizeof(name), "%s[" HOST_SIZE_T_PRINT_UNSIGNED "]%s", + field->name, (fmt_size_t)field->occurs.ntimes(), updown.data()); } } pend += snprintf(pend, string + sizeof(string) - pend, - "%02d %-20s ", field->level, name); + "%02u %-20s ", field->level, name); char offset[32] = ""; if( field->level > 1 ) { - sprintf( offset, "off%3zu", field->offset ); + sprintf( offset, "off%3" GCC_PRISZ "u", (fmt_size_t)field->offset ); } char parredef = @@ -1562,6 +1489,23 @@ field_str( const cbl_field_t *field ) { auto n = asprintf(&s, "'%s'", data); gcc_assert(n); auto eodata = data + field->data.capacity; + // It is possible for data.initial to be shorter than capacity. + + // This whole thing needs to be reexamined. There is an assumption for + // FldAlphanumeric values that the valid data in data.initial be the same + // length as data.capacity. But that does not hold true for other types. + // For example, a PIC 9V9 has a capacity of two, but the initial + // string provided by the COBOL programmer might be "1.2". Likewise, a + // PIC 999999 (capacity 5) might have a value of "1". + + for(size_t i = 0; i<field->data.capacity; i++) + { + if( data[i] == '\0' ) + { + eodata = data + i; + break; + } + } if( eodata != std::find_if_not(data, eodata, fisprint) ) { char *p = reinterpret_cast<char*>(xrealloc(s, n + 8 + 2 * field->data.capacity)); if( is_elementary(field->type) && @@ -1611,8 +1555,8 @@ field_str( const cbl_field_t *field ) { }; pend += snprintf(pend, string + sizeof(string) - pend, - "%c%3zu %-6s %c%c%c %2u{%3u,%u,%d = %s} (%s), line %d", - parredef, field->parent, offset, + "%c%3" GCC_PRISZ "u %-6s %c%c%c %2u{%3u,%u,%d = %s} (%s), line %d", + parredef, (fmt_size_t)field->parent, offset, (field->attr & global_e)? 'G' : 0x20, (field->attr & external_e)? 'E' : 0x20, storage_type, @@ -1634,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); } @@ -1694,6 +1638,9 @@ operator<<( std::ostream& os, const cbl_occurs_bounds_t& bound ) { return os << bound.lower << ',' << bound.upper; } +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wunused-function" +// Keep this debugging function around for when it is needed static std::ostream& operator<<( std::ostream& os, const cbl_field_data_t& field ) { return os << field.memsize << ',' @@ -1717,16 +1664,7 @@ operator<<( std::ostream& os, const cbl_field_t& field ) { << ',' << field.line << ',' << field.data; } - -static void -write_field_csv( size_t isym, const cbl_field_t *field ) { - static std::ofstream os( getenv("GCOBOL_DATA") ); - assert(os.is_open()); - - if( symbols.first_program < isym) { - os << isym << "," << *field << std::endl; - } -} +#pragma GCC diagnostic pop static std::map<size_t, std::set<size_t>> same_record_areas; size_t parse_error_count(); @@ -1747,11 +1685,6 @@ symbols_update( size_t first, bool parsed_ok ) { struct symbol_elem_t *p, *pend; std::list<cbl_field_t*> shared_record_areas; - if( getenv(__func__) ) { - fprintf(stderr, "Initial"); - symbols_dump(std::max(first, symbols.first_program), true); - } - for( p = symbols_begin(first); p < symbols_end(); p++ ) { if( p->type == SymAlphabet ) continue; // Alphabets already processed. @@ -1774,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(); } @@ -1796,10 +1728,6 @@ symbols_update( size_t first, bool parsed_ok ) { // no special processing for other levels } - if( getenv("GCOBOL_DATA") ) { - write_field_csv( p - symbols_begin(), field ); - } - // Update ODO field in situ. if( is_table(field) ) { size_t& odo = field->occurs.depending_on; @@ -1817,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 ) @@ -1852,28 +1780,24 @@ symbols_update( size_t first, bool parsed_ok ) { field->line, field->level_str(), field->name); } else { - dbgmsg("%s: error: data item %s #%zu '%s' capacity %u rejected", + dbgmsg("%s: error: data item %s #" HOST_SIZE_T_PRINT_UNSIGNED + " '%s' capacity %u rejected", __func__, 3 + cbl_field_type_str(field->type), - isym, field->name, field->data.capacity); + (fmt_size_t)isym, field->name, field->data.capacity); } } return 0; } if(! (field->data.memsize == 0 || field_size(field) <= field->data.memsize) ) { - dbgmsg( "%s:%d: #%zu: invalid: %s", __func__, __LINE__, - symbol_index(p), field_str(cbl_field_of(p)) ); + dbgmsg( "%s:%d: #" HOST_SIZE_T_PRINT_UNSIGNED ": invalid: %s", __func__, __LINE__, + (fmt_size_t)symbol_index(p), field_str(cbl_field_of(p)) ); } assert(field->data.memsize == 0 || field_size(field) <= field_memsize(field)); assert( !(field->data.memsize > 0 && symbol_explicitly_redefines(field)) ); } - if( getenv(__func__) ) { - fprintf(stderr, "Pre"); - symbols_dump(std::max(first, symbols.first_program), true); - } - // A shared record area has no 01 child because that child redefines its parent. for( auto sharer : shared_record_areas ) { auto redefined = cbl_field_of(symbol_at(sharer->parent)); @@ -1888,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); @@ -1895,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); @@ -1986,7 +1919,8 @@ symbol_field_forward( size_t index ) { assert( index < symbols.nelem ); symbol_elem_t *e = symbol_at(index); if( (e->type != SymField) ) { - dbgmsg("%s: logic error: #%zu is %s", __func__, index, symbol_type_str(e->type)); + dbgmsg("%s: logic error: #" HOST_SIZE_T_PRINT_UNSIGNED " is %s", + __func__, (fmt_size_t)index, symbol_type_str(e->type)); } assert(e->type == SymField); @@ -2084,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) ) { @@ -2170,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 ) { @@ -2327,7 +2261,7 @@ symbol_table_init(void) { "FILLER", 0, {}, {1,1,0,0, " "}, NULL }, { 0, FldAlphanumeric, FldInvalid, signable_e | global_e, 0,0,2, nonarray, 0, "DEBUG-CONTENTS", 0, {}, {76,76,0,0, NULL}, NULL }, -}; + }; // debug registers assert(table.nelem + COUNT_OF(debug_registers) < table.capacity); @@ -2391,8 +2325,6 @@ symbol_table_init(void) { symbols.registers.return_code = symbol_index(symbol_field(0,0, "RETURN-CODE")); symbols.registers.very_true = symbol_index(symbol_field(0,0, "_VERY_TRUE")); symbols.registers.very_false = symbol_index(symbol_field(0,0, "_VERY_FALSE")); - - if( getenv(__func__) ) symbols_dump(0, true); } /* @@ -2476,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); @@ -2489,16 +2421,16 @@ 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); } -size_t +uint64_t numeric_group_attrs( const cbl_field_t *field ) { - static const size_t inherit = signable_e | leading_e | separate_e | big_endian_e; + static const uint64_t inherit = signable_e | leading_e | separate_e | big_endian_e; static_assert(sizeof(cbl_field_t::type) < sizeof(inherit), "need bigger type"); assert(field); if( field->type == FldNumericDisplay || field->type == FldGroup ) { @@ -2534,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; } @@ -2572,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. @@ -2584,31 +2516,11 @@ 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; } } - char *s; - if( (s = getenv(__func__)) != NULL ) { - if( s[0] == 'D' ) { - for( struct symbol_elem_t *e = symbols_begin(); e < symbols_end(); e++ ) { - fprintf(stderr, "%zu: %s ", e - symbols.elems, symbol_type_str(e->type)); - if( e->type == SymField ) { - fprintf(stderr, "%s = %s", - cbl_field_of(e)->name, cbl_field_of(e)->data.initial); - } - fprintf(stderr, "\n"); - } - } - - dbgmsg( "%s:%d: %3zu %-18s %02d %-16s %u/%u/%d = '%s'", __func__, __LINE__, - field->offset, - cbl_field_type_str(field->type), field->level, field->name, - field->data.capacity, field->data.digits, field->data.rdigits, - field->data.initial? field->data.initial : "(none)" ); - } - if( is_forward(field) ) { auto *e = symbol_field( program, field->parent, field->name ); if( e ) { @@ -2723,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[] ) { @@ -2738,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 * @@ -2800,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), @@ -2813,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); @@ -2920,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; } @@ -3006,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 ); @@ -3044,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; } @@ -3062,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, @@ -3120,12 +3034,6 @@ symbol_file_record_sizes( struct cbl_file_t *file ) { output.min = cbl_field_of(&*p.first)->data.capacity; output.max = cbl_field_of(&*p.second)->data.capacity; - if( yydebug && getenv(__func__) ) { - dbgmsg("%s: %s: min '%s' %zu, max '%s' %zu", __func__, file->name, - cbl_field_of(&*p.first)->name, output.min, - cbl_field_of(&*p.second)->name, output.max); - } - assert(output.min > 0 && "min record size is 0"); assert(output.min <= output.max); @@ -3180,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, @@ -3229,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; @@ -3304,12 +3212,10 @@ new_temporary_impl( enum cbl_field_type_t type ) snprintf(f->name, sizeof(f->name), "_literal%d",++nliteral); } else { snprintf(f->name, sizeof(f->name), "_stack%d",++nstack); - - if( getenv("symbol_temporaries_free") ) { - dbgmsg("%s: %s, %s", __func__, f->name, 3 + cbl_field_type_str(f->type)); - } } + f->data.initial = name; // capture e.g. the function name + return f; } @@ -3328,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) ) { @@ -3338,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; @@ -3351,10 +3257,10 @@ new_literal_add( const char initial[], uint32_t len, enum cbl_field_attr_t attr static size_t literal_count = 1; sprintf(field->name, - "%s%c_%zd", + "%s%c_" HOST_SIZE_T_PRINT_DEC, "_literal", field->type == FldLiteralA ? 'a' : 'n', - literal_count++); + (fmt_size_t)literal_count++); return parser_symbol_add2(field); } @@ -3383,14 +3289,15 @@ new_literal( uint32_t len, const char initial[], enum cbl_field_attr_t attr ) { void temporaries_t::dump() const { extern int yylineno; - char *output = xasprintf("%4d: %zu Literals", yylineno, literals.size()); + char *output = xasprintf("%4d: " HOST_SIZE_T_PRINT_UNSIGNED " Literals", + yylineno, (fmt_size_t)literals.size()); for( const auto& elem : used ) { if( ! elem.second.empty() ) { char *so_far = output; - output = xasprintf("%s, %zu %s", + output = xasprintf("%s, " HOST_SIZE_T_PRINT_UNSIGNED " %s", so_far, - elem.second.size(), + (fmt_size_t)elem.second.size(), 3 + cbl_field_type_str(elem.first)); free(so_far); } @@ -3400,14 +3307,6 @@ temporaries_t::dump() const { } temporaries_t::~temporaries_t() { - if( getenv( "symbol_temporaries_free" ) ) { - dbgmsg("%s: %zu literals", __func__, literals.size()); - for( const auto& elem : literals ) { - const literal_an& key(elem.first); - fprintf(stderr, "%c '%s'\n", key.is_quoted? 'Q' : ' ', key.value.c_str()); - } - dump(); - } } cbl_field_t * @@ -3439,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 @@ -3451,7 +3350,6 @@ temporaries_t::acquire( cbl_field_type_t type ) { void symbol_temporaries_free() { - if( getenv(__func__) ) temporaries.dump(); for( auto& elem : temporaries.used ) { const cbl_field_type_t& type(elem.first); temporaries_t::fieldset_t& used(elem.second); @@ -3477,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); @@ -3488,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); @@ -3596,12 +3493,9 @@ 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); } - // Sat Mar 16 11:45:08 2024: require temporary environment for testing - if( getenv( "INTERNALIZE_NO") ) return data.initial; - bool using_assumed = fromcode == os_locale.assumed; if( fromcode == tocode || has_attr(hex_encoded_e) ) { @@ -3649,16 +3543,6 @@ cbl_field_t::internalize() { if( 0 != memcmp(data.initial, output.data(), out - output.data()) ) { assert(out <= output.data() + data.capacity); - if( getenv(__func__) ) { - const char *eoi = data.initial + data.capacity, *p; - char nullitude[64] = "no null"; - if( (p = std::find(data.initial, eoi, '\0')) != eoi ) { - sprintf(nullitude, "NUL @ %zu", p - data.initial); - } - dbgmsg("%s:%d: before: %-15s %-20s: '%.*s'{%u}, %s", __func__, __LINE__, - 3 + cbl_field_type_str(type), name, - data.capacity, data.initial, data.capacity, nullitude); - } dbgmsg("%s: converted '%.*s' to %s", __func__, data.capacity, data.initial, tocode); @@ -3677,18 +3561,6 @@ cbl_field_t::internalize() { free(const_cast<char*>(data.initial)); data.initial = mem; - - if( getenv(__func__) ) { - const char *eoi = data.initial + data.capacity, *p; - char nullitude[64] = "no null"; - if( (p = std::find(data.initial, eoi, '\0')) != eoi ) { - sprintf(nullitude, "NUL @ %zu", p - data.initial); - } - dbgmsg("%s:%d: after: %-15s %-20s: '%.*s'{%u}, %s", __func__, __LINE__, - "", name, - data.capacity, data.initial, data.capacity, nullitude); - } - } return data.initial; @@ -3707,8 +3579,8 @@ cbl_label_t::str() const { buf = xasprintf("%-12s %s top level [%s], line %d", type_str() + 3, name, mangled_name, line); } else { - buf = xasprintf("%-12s %s OF #%zu '%s' [%s], line %d", - type_str() + 3, name, parent, + buf = xasprintf("%-12s %s OF #" HOST_SIZE_T_PRINT_UNSIGNED " '%s' [%s], line %d", + type_str() + 3, name, (fmt_size_t)parent, cbl_label_of(symbol_at(parent))->name, mangled_name, line); } @@ -3738,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()); } /* @@ -3808,44 +3677,22 @@ common_callables_update( const size_t iprog ) { cbl_label_t * symbol_label_add( size_t program, cbl_label_t *input ) { - if( getenv(__func__) ) { - const cbl_label_t *L = input; - dbgmsg( "%s:%d: %-5s #%3zu %-9s '%s' of '%s' at line %d", __func__, __LINE__, - "input", - size_t(0), - L->type_str()+3, - L->name, - L->parent? cbl_label_of(symbol_at(L->parent))->name : "", - L->line ); - } - cbl_label_t *label = symbol_label(program, input->type, input->parent, input->name); if( label && label->type == LblNone ) { - const char *verb = "set"; label->type = input->type; label->parent = input->parent; label->line = input->line; - if( getenv(__func__) ) { - const cbl_label_t *L = label; - dbgmsg( "%s:%d: %-5s #%3zu %-9s '%s' of '%s' at line %d", - __func__, __LINE__, - verb, - symbol_elem_of(L) - symbols_begin(), - L->type_str()+3, - L->name, - L->parent? cbl_label_of(symbol_at(L->parent))->name : "", - L->line ); - } return label; } // Set the program's mangled name, dehyphenated and uniqified by parent index. if( input->type == LblProgram ) { char *psz = cobol_name_mangler(input->name); - input->mangled_name = xasprintf("%s.%zu", psz, input->parent); + input->mangled_name = xasprintf("%s." HOST_SIZE_T_PRINT_UNSIGNED, + psz, (fmt_size_t)input->parent); free(psz); } @@ -3858,59 +3705,39 @@ 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 if( e->elem.label.line < 0 ) e->elem.label.line = -e->elem.label.line; - if( getenv(__func__) ) { - const cbl_label_t *L = cbl_label_of(e); - dbgmsg( "%s:%d: added #%3zu %-9s '%s' of '%s' at line %d", __func__, __LINE__, - e - symbols_begin(), - L->type_str()+3, - L->name, - L->parent? cbl_label_of(symbol_at(L->parent))->name : "", - L->line ); - } symbols.labelmap_add(e); return cbl_label_of(e); } /* - * 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 +3750,8 @@ symbol_program_add( size_t program, cbl_label_t *input ) // Set the program's mangled name, dehyphenated and uniqified by parent index. char *psz = cobol_name_mangler(input->name); - elem.elem.label.mangled_name = xasprintf("%s.%zu", psz, input->parent); + elem.elem.label.mangled_name = xasprintf("%s." HOST_SIZE_T_PRINT_UNSIGNED, + psz, (fmt_size_t)input->parent); free(psz); e = std::find_if( symbols_begin(program), symbols_end(), @@ -3965,11 +3793,6 @@ symbol_special_add( size_t program, struct cbl_special_name_t *special ) struct symbol_elem_t *e = symbol_special(program, special->name); if( e ) { - cbl_special_name_t *s = cbl_special_name_of(e); - if( getenv(__func__) ) { - dbgmsg("%s:%d matches %s %d (%s)", __func__, __LINE__, - special->name, int(s->id), s->name); - } return e; } assert(e == NULL); @@ -3980,11 +3803,6 @@ symbol_special_add( size_t program, struct cbl_special_name_t *special ) cbl_errx( "%s:%d: could not add '%s'", __func__, __LINE__, special->name); } - if( getenv(__func__) ) { - dbgmsg( "%s:%d: added special '%s'", __func__, __LINE__, - e->elem.special.name); - } - elem_key_t key(program, cbl_special_name_of(e)->name); symbols.specials[key] = symbol_index(e); @@ -4061,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; @@ -4090,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--) @@ -4103,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; } @@ -4112,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'; @@ -4135,7 +3953,6 @@ expand_picture(const char *picture) { pcurrency[i] = 'B'; } - dest_length += sign_length; } } @@ -4366,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) || @@ -4400,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 @@ -4411,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 ) { @@ -4433,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 @@ -4463,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); @@ -4481,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); } @@ -4614,8 +4428,8 @@ symbol_forward_names( size_t ifield ) { for( auto sym = symbols_begin(ifield); sym && sym->type == SymField; ) { const cbl_field_t *field = cbl_field_of(sym); if( !(field->type == FldForward) ) { - dbgmsg("%s:%d: logic error, not FldForward: #%zu %s", - __func__, __LINE__, symbol_index(sym), field_str(field)); + dbgmsg("%s:%d: logic error, not FldForward: #" HOST_SIZE_T_PRINT_UNSIGNED " %s", + __func__, __LINE__, (fmt_size_t)symbol_index(sym), field_str(field)); } assert(field->type == FldForward); @@ -4638,8 +4452,9 @@ symbol_forward_to( size_t fwd ) { if( !elem.second ) { const auto& field = *cbl_field_of(symbols_begin(fwd)); if( yydebug ) - dbgmsg("%s:%d: no symbol found for #%zu %s %s", __func__, __LINE__, - fwd, cbl_field_type_str(field.type), field.name); + dbgmsg("%s:%d: no symbol found for #" HOST_SIZE_T_PRINT_UNSIGNED " %s %s", + __func__, __LINE__, + (fmt_size_t)fwd, cbl_field_type_str(field.type), field.name); return fwd; } @@ -4655,13 +4470,14 @@ 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 ) { - dbgmsg("%s:%d: key %d: #%zu %s of %s is %s", "deforward", __LINE__, - keys[ifile]++, ifield, field->name, file->name, + 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, cbl_field_type_str(field->type) + 3); } @@ -4715,7 +4531,7 @@ cbl_file_key_t::str() const { *p++ = '['; for( auto f = fields; f < fields + nfield; f++) { - auto n = sprintf(p, "%s%zu", sep, *f); + auto n = sprintf(p, "%s" HOST_SIZE_T_PRINT_UNSIGNED, sep, (fmt_size_t)*f); p += n; sep = ", "; } @@ -4745,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()); } /* @@ -4827,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 ); @@ -4857,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 c231763..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> @@ -57,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 { @@ -128,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 ); @@ -146,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 ); @@ -169,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; } @@ -215,7 +219,6 @@ bool decimal_is_comma(); enum symbol_type_t { SymFilename, - SymFunction, SymField, SymLabel, // section, paragraph, or label SymSpecial, @@ -261,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) @@ -324,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); @@ -343,9 +361,7 @@ struct cbl_field_data_t { cbl_field_data_t& valify() { assert(initial); - const size_t len = strlen(initial); - std::string input(len + 1, '\0'); // add a NUL - std::copy(initial, initial + len, input.begin()); + std::string input(initial); if( decimal_is_comma() ) { std::replace(input.begin(), input.end(), ',', '.'); } @@ -411,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; } @@ -445,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 ); }; /* @@ -494,7 +513,7 @@ bool is_elementary( enum cbl_field_type_t type ); struct cbl_field_t { size_t offset; enum cbl_field_type_t type, usage; - size_t attr; + uint64_t attr; static_assert(sizeof(attr) == sizeof(cbl_field_attr_t), "wrong attr size"); size_t parent; // symbols[] index of our parent size_t our_index; // symbols[] index of this field, set in symbol_add() @@ -513,7 +532,6 @@ struct cbl_field_t { tree data_decl_node; // Reference to the run-time data of the COBOL variable // // For linkage_e variables, data_decl_node is a pointer // // to the data, rather than the actual data - tree literal_decl_node; // This is a FLOAT128 version of data.value void set_linkage( cbl_ffi_crv_t crv, bool optional ) { linkage.optional = optional; @@ -597,8 +615,8 @@ struct cbl_field_t { bool has_attr( cbl_field_attr_t attr ) const { return cbl_field_attr_t(this->attr & attr) == attr; } - size_t set_attr( cbl_field_attr_t attr ); - size_t clear_attr( cbl_field_attr_t attr ); + uint64_t set_attr( cbl_field_attr_t attr ); + uint64_t clear_attr( cbl_field_attr_t attr ); const char * attr_str( const std::vector<cbl_field_attr_t>& attrs ) const; bool is_justifiable() const { @@ -632,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; @@ -639,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 ); } @@ -653,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[] ) { @@ -707,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 ); @@ -773,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_" @@ -783,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 ) { @@ -802,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 { @@ -909,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() ) @@ -943,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 ); @@ -955,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 ); @@ -1169,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; @@ -1192,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; @@ -1273,7 +1320,8 @@ struct function_descr_t { static function_descr_t init( const char name[] ) { function_descr_t descr = {}; if( -1 == snprintf( descr.name, sizeof(descr.name), "%s", name ) ) { - dbgmsg("name truncated to '%s' (max %zu characters)", name); + dbgmsg("name truncated to '%s' (max " HOST_SIZE_T_PRINT_UNSIGNED + " characters)", name, (fmt_size_t)sizeof(descr.name)); } return descr; // truncation also reported elsewhere ? } @@ -1416,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++); } } @@ -1427,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++); } } @@ -1449,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 ) { @@ -1472,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 ) { @@ -1518,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) @@ -1529,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; @@ -1556,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; @@ -1588,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; @@ -1635,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) {} @@ -1689,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; @@ -1721,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); } @@ -1728,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); } @@ -1735,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); } @@ -1742,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); } @@ -1749,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); } @@ -1762,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 ); @@ -1789,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(); @@ -1811,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; } @@ -1886,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); } @@ -1942,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 @@ -1950,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 { @@ -2002,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(); }; @@ -2024,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)); @@ -2049,11 +2126,12 @@ struct cbl_perform_tgt_t { void dump() const { assert(ifrom); if( !ito ) { - dbgmsg( "%s:%d: #%3zu %s", __PRETTY_FUNCTION__, __LINE__, - ifrom, from()->str() ); + dbgmsg( "%s:%d: #%3" GCC_PRISZ "u %s", __PRETTY_FUNCTION__, __LINE__, + (fmt_size_t)ifrom, from()->str() ); } else { - dbgmsg( "%s:%d: #%3zu %s THRU #%3zu %s", __PRETTY_FUNCTION__, __LINE__, - ifrom, from()->str(), ito, to()->str() ); + dbgmsg( "%s:%d: #%3" GCC_PRISZ "u %s THRU #%3" GCC_PRISZ "u %s", + __PRETTY_FUNCTION__, __LINE__, + (fmt_size_t)ifrom, from()->str(), (fmt_size_t)ito, to()->str() ); } } @@ -2067,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) @@ -2092,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; } @@ -2118,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); @@ -2205,6 +2284,10 @@ class name_queue_t : private std::queue<cbl_namelocs_t> }; +const std::string& keyword_alias_add( const std::string& keyword, + const std::string& alias ); +int binary_integer_usage_of( const char name[] ); + void tee_up_empty(); void tee_up_name( const YYLTYPE& loc, const char name[] ); cbl_namelist_t teed_up_names(); @@ -2228,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 ); @@ -2238,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 ); @@ -2246,12 +2329,12 @@ cbl_file_t * symbol_record_file( const cbl_field_t *f ); struct cbl_field_t * symbol_find_odo( const cbl_field_t * field ); -size_t numeric_group_attrs( const cbl_field_t *field ); +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; } @@ -2263,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 ); @@ -2313,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) {} @@ -2367,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 ); @@ -2385,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); @@ -2400,4 +2480,6 @@ void gcc_location_set( const LOC& loc ); // create an entire .h module. So, I stuck it here. size_t count_characters(const char *in, size_t length); +void current_enabled_ecs( tree ena ); + #endif diff --git a/gcc/cobol/symfind.cc b/gcc/cobol/symfind.cc index 8995715..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); @@ -147,13 +147,14 @@ dump_symbol_map2( const field_key_t& key, const std::list<size_t>& candidates ) for( auto candidate : candidates ) { char *tmp = fields; - fields = xasprintf("%s%s %3zu", tmp? tmp : "", sep, candidate); + fields = xasprintf("%s%s %3" GCC_PRISZ "u", + tmp? tmp : "", sep, (fmt_size_t)candidate); sep[0] = ','; free(tmp); } - dbgmsg( "%s:%d: %3zu %s {%s}", __func__, __LINE__, - key.program, key.name, fields ); + dbgmsg( "%s:%d: %3" GCC_PRISZ "u %s {%s}", __func__, __LINE__, + (fmt_size_t)key.program, key.name, fields ); free(fields); } @@ -179,7 +180,8 @@ dump_symbol_map_value( const char name[], const symbol_map_t::value_type& value for( ; p != value.second.end(); p++ ) { char *tmp = ancestry; - ancestry = xasprintf("%s%s %3zu", tmp? tmp : "", sep, *p); + ancestry = xasprintf("%s%s %3" GCC_PRISZ "u", + tmp? tmp : "", sep, (fmt_size_t)*p); sep[0] = ','; free(tmp); } @@ -200,12 +202,6 @@ field_structure( symbol_elem_t& sym ) { static const symbol_map_t::value_type none( symbol_map_t::key_type( 0, "", 0 ), std::vector<size_t>() ); - if( getenv(__func__) && sym.type == SymField ) { - const auto& field = *cbl_field_of(&sym); - dbgmsg("%s: #%zu %s: '%s' is_data_field: %s", __func__, - symbol_index(&sym), cbl_field_type_str(field.type), field.name, - is_data_field(sym)? "yes" : "no" ); - } if( !is_data_field(sym) ) return none; cbl_field_t *field = cbl_field_of(&sym); @@ -233,12 +229,6 @@ field_structure( symbol_elem_t& sym ) { } } - if( getenv(__func__) && yydebug ) { - dbgmsg( "%s:%d: '%s' has %zu ancestors", __func__, __LINE__, - elem.first.c_str(), elem.second.size() ); - dump_symbol_map_value(__func__, elem); - } - return elem; } @@ -268,14 +258,11 @@ build_symbol_map() { symbol_map.erase(sym_name_t("")); if( yydebug ) { - dbgmsg( "%s:%d: %zu of %zu symbols inserted into %zu in symbol_map", - __func__, __LINE__, nsym, end, symbol_map.size() ); - - if( getenv(__func__) ) { - for( const auto& elem : symbol_map ) { - dump_symbol_map_value1(elem); - } - } + dbgmsg( "%s:%d: " HOST_SIZE_T_PRINT_UNSIGNED " of " + HOST_SIZE_T_PRINT_UNSIGNED " symbols inserted into " + HOST_SIZE_T_PRINT_UNSIGNED " in symbol_map", + __func__, __LINE__, (fmt_size_t)nsym, (fmt_size_t)end, + (fmt_size_t)symbol_map.size() ); } } @@ -288,18 +275,15 @@ 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; - if( tf && getenv("is_name") ) { - dump_key( "matched", elem.first ); - } return tf; } protected: void dump_key( const char tag[], const symbol_map_t::key_type& key ) const { - dbgmsg( "symbol_map key: %s { %3zu %3zu %s }", - tag, key.program, key.parent, key.name ); + dbgmsg( "symbol_map key: %s { %3" GCC_PRISZ "u %3" GCC_PRISZ "u %s }", + tag, (fmt_size_t)key.program, (fmt_size_t)key.parent, key.name ); } }; @@ -314,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(), @@ -347,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); } @@ -357,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; } @@ -437,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; @@ -446,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) ); } @@ -480,14 +464,16 @@ symbol_match2( size_t program, sep = ""; for( auto field : fields ) { char *partial = fieldstr; - int asret = asprintf(&fieldstr, "%s%s%zu", partial? partial : "", sep, field); + int asret = asprintf(&fieldstr, "%s%s" HOST_SIZE_T_PRINT_UNSIGNED, + partial? partial : "", sep, (fmt_size_t)field); assert(asret); sep = ", "; assert(fieldstr); free(partial); } - dbgmsg("%s: '%s' matches %zu fields: {%s}", __func__, ancestry, fields.size(), fieldstr); + dbgmsg("%s: '%s' matches " HOST_SIZE_T_PRINT_UNSIGNED " fields: {%s}", + __func__, ancestry, (fmt_size_t)fields.size(), fieldstr); free(fieldstr); } free(ancestry); @@ -502,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; @@ -558,8 +544,8 @@ symbol_find( size_t program, std::list<const char *> names ) { return std::pair<symbol_elem_t *, bool>(NULL, false); } if( yydebug ) { - dbgmsg( "%s:%d: '%s' has %zu possible matches", - __func__, __LINE__, names.back(), items.size() ); + dbgmsg( "%s:%d: '%s' has " HOST_SIZE_T_PRINT_UNSIGNED " possible matches", + __func__, __LINE__, names.back(), (fmt_size_t)items.size() ); std::for_each( items.begin(), items.end(), dump_symbol_map_value1 ); } } @@ -575,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(), @@ -587,12 +573,6 @@ symbol_elem_t * symbol_find_of( size_t program, std::list<const char *> names, size_t group ) { symbol_map_t input = symbol_match(program, names); - if( getenv(__func__) && input.size() != 1 ) { - dbgmsg( "%s:%d: '%s' has %zu candidates for group %zu", - __func__, __LINE__, names.back(), input.size(), group ); - std::for_each( input.begin(), input.end(), dump_symbol_map_value1 ); - } - symbol_map_t items; std::copy_if( input.begin(), input.end(), std::inserter(items, items.begin()), in_group(group) ); @@ -604,8 +584,8 @@ symbol_find_of( size_t program, std::list<const char *> names, size_t group ) { } if( yydebug ) { - dbgmsg( "%s:%d: '%s' has %zu possible matches", - __func__, __LINE__, names.back(), input.size() ); + dbgmsg( "%s:%d: '%s' has " HOST_SIZE_T_PRINT_UNSIGNED " possible matches", + __func__, __LINE__, names.back(), (fmt_size_t)input.size() ); std::for_each( input.begin(), input.end(), dump_symbol_map_value1 ); } diff --git a/gcc/cobol/token_names.h b/gcc/cobol/token_names.h index a082078..4b24fc6 100644 --- a/gcc/cobol/token_names.h +++ b/gcc/cobol/token_names.h @@ -1,1373 +1,1378 @@ // generated by ./token_names.h.gen ../../build/gcc/cobol/parse.h -// Fri Mar 21 10:13:54 CET 2025 +// Thu May 8 18:53:33 EDT 2025 tokens = { - { "identification", IDENTIFICATION_DIV }, // 258 - { "environment", ENVIRONMENT_DIV }, // 259 - { "procedure", PROCEDURE_DIV }, // 260 - { "data", DATA_DIV }, // 261 - { "file", FILE_SECT }, // 262 - { "input-output", INPUT_OUTPUT_SECT }, // 263 - { "linkage", LINKAGE_SECT }, // 264 - { "local-storage", LOCAL_STORAGE_SECT }, // 265 - { "working-storage", WORKING_STORAGE_SECT }, // 266 - { "object-computer", OBJECT_COMPUTER }, // 267 - { "display-of", DISPLAY_OF }, // 268 - { "end-function", END_FUNCTION }, // 269 - { "end-program", END_PROGRAM }, // 270 - { "end-subprogram", END_SUBPROGRAM }, // 271 - { "justified", JUSTIFIED }, // 272 - { "returning", RETURNING }, // 273 - { "no-condition", NO_CONDITION }, // 274 - { "alnum", ALNUM }, // 275 - { "alphed", ALPHED }, // 276 - { "error", ERROR }, // 277 - { "exception", EXCEPTION }, // 278 - { "size-error", SIZE_ERROR }, // 279 - { "exception-name", EXCEPTION_NAME }, // 280 - { "level", LEVEL }, // 281 - { "level66", LEVEL66 }, // 282 - { "level78", LEVEL78 }, // 283 - { "level88", LEVEL88 }, // 284 - { "class-name", CLASS_NAME }, // 285 - { "name", NAME }, // 286 - { "name88", NAME88 }, // 287 - { "nume", NUME }, // 288 - { "numed", NUMED }, // 289 - { "numed-cr", NUMED_CR }, // 290 - { "numed-db", NUMED_DB }, // 291 - { "ninedot", NINEDOT }, // 292 - { "nines", NINES }, // 293 - { "ninev", NINEV }, // 294 - { "pic-p", PIC_P }, // 295 - { "spaces", SPACES }, // 296 - { "space", SPACES }, // 296 - { "literal", LITERAL }, // 297 - { "end", END }, // 298 - { "eop", EOP }, // 299 - { "filename", FILENAME }, // 300 - { "invalid", INVALID }, // 301 - { "number", NUMBER }, // 302 - { "negative", NEGATIVE }, // 303 - { "numstr", NUMSTR }, // 304 - { "overflow", OVERFLOW }, // 305 - { "computational", COMPUTATIONAL }, // 306 - { "perform", PERFORM }, // 307 - { "backward", BACKWARD }, // 308 - { "positive", POSITIVE }, // 309 - { "pointer", POINTER }, // 310 - { "section", SECTION }, // 311 - { "standard-alphabet", STANDARD_ALPHABET }, // 312 - { "switch", SWITCH }, // 313 - { "upsi", UPSI }, // 314 - { "zero", ZERO }, // 315 - { "zeros", ZERO }, // 315 - { "zeroes", ZERO }, // 315 - { "sysin", SYSIN }, // 316 - { "sysipt", SYSIPT }, // 317 - { "sysout", SYSOUT }, // 318 - { "syslist", SYSLIST }, // 319 - { "syslst", SYSLST }, // 320 - { "syspunch", SYSPUNCH }, // 321 - { "syspch", SYSPCH }, // 322 - { "console", CONSOLE }, // 323 - { "c01", C01 }, // 324 - { "c02", C02 }, // 325 - { "c03", C03 }, // 326 - { "c04", C04 }, // 327 - { "c05", C05 }, // 328 - { "c06", C06 }, // 329 - { "c07", C07 }, // 330 - { "c08", C08 }, // 331 - { "c09", C09 }, // 332 - { "c10", C10 }, // 333 - { "c11", C11 }, // 334 - { "c12", C12 }, // 335 - { "csp", CSP }, // 336 - { "s01", S01 }, // 337 - { "s02", S02 }, // 338 - { "s03", S03 }, // 339 - { "s04", S04 }, // 340 - { "s05", S05 }, // 341 - { "afp-5a", AFP_5A }, // 342 - { "stdin", STDIN }, // 343 - { "stdout", STDOUT }, // 344 - { "stderr", STDERR }, // 345 - { "list", LIST }, // 346 - { "map", MAP }, // 347 - { "nolist", NOLIST }, // 348 - { "nomap", NOMAP }, // 349 - { "nosource", NOSOURCE }, // 350 - { "might-be", MIGHT_BE }, // 351 - { "function-udf", FUNCTION_UDF }, // 352 - { "function-udf-0", FUNCTION_UDF_0 }, // 353 - { "date-fmt", DATE_FMT }, // 354 - { "time-fmt", TIME_FMT }, // 355 - { "datetime-fmt", DATETIME_FMT }, // 356 - { "basis", BASIS }, // 357 - { "cbl", CBL }, // 358 - { "constant", CONSTANT }, // 359 - { "copy", COPY }, // 360 - { "defined", DEFINED }, // 361 - { "enter", ENTER }, // 362 - { "feature", FEATURE }, // 363 - { "insertt", INSERTT }, // 364 - { "lsub", LSUB }, // 365 - { "parameter", PARAMETER_kw }, // 366 - { "override", OVERRIDE }, // 367 - { "ready", READY }, // 368 - { "reset", RESET }, // 369 - { "rsub", RSUB }, // 370 - { "service-reload", SERVICE_RELOAD }, // 371 - { "star-cbl", STAR_CBL }, // 372 - { "subscript", SUBSCRIPT }, // 373 - { "suppress", SUPPRESS }, // 374 - { "title", TITLE }, // 375 - { "trace", TRACE }, // 376 - { "use", USE }, // 377 - { "cobol-words", COBOL_WORDS }, // 378 - { "equate", EQUATE }, // 379 - { "undefine", UNDEFINE }, // 380 - { "cdf-define", CDF_DEFINE }, // 381 - { "cdf-display", CDF_DISPLAY }, // 382 - { "cdf-if", CDF_IF }, // 383 - { "cdf-else", CDF_ELSE }, // 384 - { "cdf-end-if", CDF_END_IF }, // 385 - { "cdf-evaluate", CDF_EVALUATE }, // 386 - { "cdf-when", CDF_WHEN }, // 387 - { "cdf-end-evaluate", CDF_END_EVALUATE }, // 388 - { "call-cobol", CALL_COBOL }, // 389 - { "call-verbatim", CALL_VERBATIM }, // 390 - { "if", IF }, // 391 - { "then", THEN }, // 392 - { "else", ELSE }, // 393 - { "sentence", SENTENCE }, // 394 - { "accept", ACCEPT }, // 395 - { "add", ADD }, // 396 - { "alter", ALTER }, // 397 - { "call", CALL }, // 398 - { "cancel", CANCEL }, // 399 - { "close", CLOSE }, // 400 - { "compute", COMPUTE }, // 401 - { "continue", CONTINUE }, // 402 - { "delete", DELETE }, // 403 - { "display", DISPLAY }, // 404 - { "divide", DIVIDE }, // 405 - { "evaluate", EVALUATE }, // 406 - { "exit", EXIT }, // 407 - { "filler", FILLER_kw }, // 408 - { "goback", GOBACK }, // 409 - { "goto", GOTO }, // 410 - { "initialize", INITIALIZE }, // 411 - { "inspect", INSPECT }, // 412 - { "merge", MERGE }, // 413 - { "move", MOVE }, // 414 - { "multiply", MULTIPLY }, // 415 - { "open", OPEN }, // 416 - { "paragraph", PARAGRAPH }, // 417 - { "read", READ }, // 418 - { "release", RELEASE }, // 419 - { "return", RETURN }, // 420 - { "rewrite", REWRITE }, // 421 - { "search", SEARCH }, // 422 - { "set", SET }, // 423 - { "select", SELECT }, // 424 - { "sort", SORT }, // 425 - { "sort-merge", SORT_MERGE }, // 426 - { "string", STRING_kw }, // 427 - { "stop", STOP }, // 428 - { "subtract", SUBTRACT }, // 429 - { "start", START }, // 430 - { "unstring", UNSTRING }, // 431 - { "write", WRITE }, // 432 - { "when", WHEN }, // 433 - { "abs", ABS }, // 434 - { "access", ACCESS }, // 435 - { "acos", ACOS }, // 436 - { "actual", ACTUAL }, // 437 - { "advancing", ADVANCING }, // 438 - { "after", AFTER }, // 439 - { "all", ALL }, // 440 - { "allocate", ALLOCATE }, // 441 - { "alphabet", ALPHABET }, // 442 - { "alphabetic", ALPHABETIC }, // 443 - { "alphabetic-lower", ALPHABETIC_LOWER }, // 444 - { "alphabetic-upper", ALPHABETIC_UPPER }, // 445 - { "alphanumeric", ALPHANUMERIC }, // 446 - { "alphanumeric-edited", ALPHANUMERIC_EDITED }, // 447 - { "also", ALSO }, // 448 - { "alternate", ALTERNATE }, // 449 - { "annuity", ANNUITY }, // 450 - { "anum", ANUM }, // 451 - { "any", ANY }, // 452 - { "anycase", ANYCASE }, // 453 - { "apply", APPLY }, // 454 - { "are", ARE }, // 455 - { "area", AREA }, // 456 - { "areas", AREAS }, // 457 - { "as", AS }, // 458 - { "ascending", ASCENDING }, // 459 - { "activating", ACTIVATING }, // 460 - { "asin", ASIN }, // 461 - { "assign", ASSIGN }, // 462 - { "at", AT }, // 463 - { "atan", ATAN }, // 464 - { "based", BASED }, // 465 - { "baseconvert", BASECONVERT }, // 466 - { "before", BEFORE }, // 467 - { "binary", BINARY }, // 468 - { "bit", BIT }, // 469 - { "bit-of", BIT_OF }, // 470 - { "bit-to-char", BIT_TO_CHAR }, // 471 - { "blank", BLANK }, // 472 - { "block", BLOCK_kw }, // 473 - { "boolean-of-integer", BOOLEAN_OF_INTEGER }, // 474 - { "bottom", BOTTOM }, // 475 - { "by", BY }, // 476 - { "byte", BYTE }, // 477 - { "byte-length", BYTE_LENGTH }, // 478 - { "cf", CF }, // 479 - { "ch", CH }, // 480 - { "changed", CHANGED }, // 481 - { "char", CHAR }, // 482 - { "char-national", CHAR_NATIONAL }, // 483 - { "character", CHARACTER }, // 484 - { "characters", CHARACTERS }, // 485 - { "checking", CHECKING }, // 486 - { "class", CLASS }, // 487 - { "cobol", COBOL }, // 488 - { "code", CODE }, // 489 - { "code-set", CODESET }, // 490 - { "collating", COLLATING }, // 491 - { "column", COLUMN }, // 492 - { "combined-datetime", COMBINED_DATETIME }, // 493 - { "comma", COMMA }, // 494 - { "command-line", COMMAND_LINE }, // 495 - { "command-line-count", COMMAND_LINE_COUNT }, // 496 - { "commit", COMMIT }, // 497 - { "common", COMMON }, // 498 - { "concat", CONCAT }, // 499 - { "condition", CONDITION }, // 500 - { "configuration", CONFIGURATION_SECT }, // 501 - { "contains", CONTAINS }, // 502 - { "content", CONTENT }, // 503 - { "control", CONTROL }, // 504 - { "controls", CONTROLS }, // 505 - { "convert", CONVERT }, // 506 - { "converting", CONVERTING }, // 507 - { "corresponding", CORRESPONDING }, // 508 - { "cos", COS }, // 509 - { "count", COUNT }, // 510 - { "currency", CURRENCY }, // 511 - { "current", CURRENT }, // 512 - { "current-date", CURRENT_DATE }, // 513 - { "data", DATA }, // 514 - { "date", DATE }, // 515 - { "date-compiled", DATE_COMPILED }, // 516 - { "date-of-integer", DATE_OF_INTEGER }, // 517 - { "date-to-yyyymmdd", DATE_TO_YYYYMMDD }, // 518 - { "date-written", DATE_WRITTEN }, // 519 - { "day", DAY }, // 520 - { "day-of-integer", DAY_OF_INTEGER }, // 521 - { "day-of-week", DAY_OF_WEEK }, // 522 - { "day-to-yyyyddd", DAY_TO_YYYYDDD }, // 523 - { "dbcs", DBCS }, // 524 - { "de", DE }, // 525 - { "debugging", DEBUGGING }, // 526 - { "decimal-point", DECIMAL_POINT }, // 527 - { "declaratives", DECLARATIVES }, // 528 - { "default", DEFAULT }, // 529 - { "delimited", DELIMITED }, // 530 - { "delimiter", DELIMITER }, // 531 - { "depending", DEPENDING }, // 532 - { "descending", DESCENDING }, // 533 - { "detail", DETAIL }, // 534 - { "direct", DIRECT }, // 535 - { "direct-access", DIRECT_ACCESS }, // 536 - { "down", DOWN }, // 537 - { "duplicates", DUPLICATES }, // 538 - { "dynamic", DYNAMIC }, // 539 - { "e", E }, // 540 - { "ebcdic", EBCDIC }, // 541 - { "ec", EC }, // 542 - { "egcs", EGCS }, // 543 - { "entry", ENTRY }, // 544 - { "environment", ENVIRONMENT }, // 545 - { "equal", EQUAL }, // 546 - { "every", EVERY }, // 547 - { "examine", EXAMINE }, // 548 - { "exhibit", EXHIBIT }, // 549 - { "exp", EXP }, // 550 - { "exp10", EXP10 }, // 551 - { "extend", EXTEND }, // 552 - { "external", EXTERNAL }, // 553 - { "exception-file", EXCEPTION_FILE }, // 554 - { "exception-file-n", EXCEPTION_FILE_N }, // 555 - { "exception-location", EXCEPTION_LOCATION }, // 556 - { "exception-location-n", EXCEPTION_LOCATION_N }, // 557 - { "exception-statement", EXCEPTION_STATEMENT }, // 558 - { "exception-status", EXCEPTION_STATUS }, // 559 - { "factorial", FACTORIAL }, // 560 - { "false", FALSE_kw }, // 561 - { "fd", FD }, // 562 - { "file-control", FILE_CONTROL }, // 563 - { "file", FILE_KW }, // 564 - { "file-limit", FILE_LIMIT }, // 565 - { "final", FINAL }, // 566 - { "finally", FINALLY }, // 567 - { "find-string", FIND_STRING }, // 568 - { "first", FIRST }, // 569 - { "fixed", FIXED }, // 570 - { "footing", FOOTING }, // 571 - { "for", FOR }, // 572 - { "formatted-current-date", FORMATTED_CURRENT_DATE }, // 573 - { "formatted-date", FORMATTED_DATE }, // 574 - { "formatted-datetime", FORMATTED_DATETIME }, // 575 - { "formatted-time", FORMATTED_TIME }, // 576 - { "form-overflow", FORM_OVERFLOW }, // 577 - { "free", FREE }, // 578 - { "fraction-part", FRACTION_PART }, // 579 - { "from", FROM }, // 580 - { "function", FUNCTION }, // 581 - { "generate", GENERATE }, // 582 - { "giving", GIVING }, // 583 - { "global", GLOBAL }, // 584 - { "go", GO }, // 585 - { "group", GROUP }, // 586 - { "heading", HEADING }, // 587 - { "hex", HEX }, // 588 - { "hex-of", HEX_OF }, // 589 - { "hex-to-char", HEX_TO_CHAR }, // 590 - { "high-values", HIGH_VALUES }, // 591 - { "highest-algebraic", HIGHEST_ALGEBRAIC }, // 592 - { "hold", HOLD }, // 593 - { "ibm-360", IBM_360 }, // 594 - { "in", IN }, // 595 - { "include", INCLUDE }, // 596 - { "index", INDEX }, // 597 - { "indexed", INDEXED }, // 598 - { "indicate", INDICATE }, // 599 - { "initial", INITIAL_kw }, // 600 - { "initiate", INITIATE }, // 601 - { "input", INPUT }, // 602 - { "installation", INSTALLATION }, // 603 - { "interface", INTERFACE }, // 604 - { "integer", INTEGER }, // 605 - { "integer-of-boolean", INTEGER_OF_BOOLEAN }, // 606 - { "integer-of-date", INTEGER_OF_DATE }, // 607 - { "integer-of-day", INTEGER_OF_DAY }, // 608 - { "integer-of-formatted-date", INTEGER_OF_FORMATTED_DATE }, // 609 - { "integer-part", INTEGER_PART }, // 610 - { "into", INTO }, // 611 - { "intrinsic", INTRINSIC }, // 612 - { "invoke", INVOKE }, // 613 - { "i-o", IO }, // 614 - { "i-o-control", IO_CONTROL }, // 615 - { "is", IS }, // 616 - { "isnt", ISNT }, // 617 - { "kanji", KANJI }, // 618 - { "key", KEY }, // 619 - { "label", LABEL }, // 620 - { "last", LAST }, // 621 - { "leading", LEADING }, // 622 - { "left", LEFT }, // 623 - { "length", LENGTH }, // 624 - { "length-of", LENGTH_OF }, // 625 - { "limit", LIMIT }, // 626 - { "limits", LIMITS }, // 627 - { "line", LINE }, // 628 - { "lines", LINES }, // 629 - { "line-counter", LINE_COUNTER }, // 630 - { "linage", LINAGE }, // 631 - { "linkage", LINKAGE }, // 632 - { "locale", LOCALE }, // 633 - { "locale-compare", LOCALE_COMPARE }, // 634 - { "locale-date", LOCALE_DATE }, // 635 - { "locale-time", LOCALE_TIME }, // 636 - { "locale-time-from-seconds", LOCALE_TIME_FROM_SECONDS }, // 637 - { "local-storage", LOCAL_STORAGE }, // 638 - { "location", LOCATION }, // 639 - { "lock", LOCK }, // 640 - { "lock-on", LOCK_ON }, // 641 - { "log", LOG }, // 642 - { "log10", LOG10 }, // 643 - { "lower-case", LOWER_CASE }, // 644 - { "low-values", LOW_VALUES }, // 645 - { "lowest-algebraic", LOWEST_ALGEBRAIC }, // 646 - { "lparen", LPAREN }, // 647 - { "manual", MANUAL }, // 648 - { "maxx", MAXX }, // 649 - { "mean", MEAN }, // 650 - { "median", MEDIAN }, // 651 - { "midrange", MIDRANGE }, // 652 - { "minn", MINN }, // 653 - { "multiple", MULTIPLE }, // 654 - { "mod", MOD }, // 655 - { "mode", MODE }, // 656 - { "module-name", MODULE_NAME }, // 657 - { "named", NAMED }, // 658 - { "nat", NAT }, // 659 - { "national", NATIONAL }, // 660 - { "national-edited", NATIONAL_EDITED }, // 661 - { "national-of", NATIONAL_OF }, // 662 - { "native", NATIVE }, // 663 - { "nested", NESTED }, // 664 - { "next", NEXT }, // 665 - { "no", NO }, // 666 - { "note", NOTE }, // 667 - { "nulls", NULLS }, // 668 - { "null", NULLS }, // 668 - { "nullptr", NULLPTR }, // 669 - { "numeric", NUMERIC }, // 670 - { "numeric-edited", NUMERIC_EDITED }, // 671 - { "numval", NUMVAL }, // 672 - { "numval-c", NUMVAL_C }, // 673 - { "numval-f", NUMVAL_F }, // 674 - { "occurs", OCCURS }, // 675 - { "of", OF }, // 676 - { "off", OFF }, // 677 - { "omitted", OMITTED }, // 678 - { "on", ON }, // 679 - { "only", ONLY }, // 680 - { "optional", OPTIONAL }, // 681 - { "options", OPTIONS }, // 682 - { "ord", ORD }, // 683 - { "order", ORDER }, // 684 - { "ord-max", ORD_MAX }, // 685 - { "ord-min", ORD_MIN }, // 686 - { "organization", ORGANIZATION }, // 687 - { "other", OTHER }, // 688 - { "otherwise", OTHERWISE }, // 689 - { "output", OUTPUT }, // 690 - { "packed-decimal", PACKED_DECIMAL }, // 691 - { "padding", PADDING }, // 692 - { "page", PAGE }, // 693 - { "page-counter", PAGE_COUNTER }, // 694 - { "pf", PF }, // 695 - { "ph", PH }, // 696 - { "pi", PI }, // 697 - { "pic", PIC }, // 698 - { "picture", PICTURE }, // 699 - { "plus", PLUS }, // 700 - { "present-value", PRESENT_VALUE }, // 701 - { "print-switch", PRINT_SWITCH }, // 702 - { "procedure", PROCEDURE }, // 703 - { "procedures", PROCEDURES }, // 704 - { "proceed", PROCEED }, // 705 - { "process", PROCESS }, // 706 - { "program-id", PROGRAM_ID }, // 707 - { "program", PROGRAM_kw }, // 708 - { "property", PROPERTY }, // 709 - { "prototype", PROTOTYPE }, // 710 - { "pseudotext", PSEUDOTEXT }, // 711 - { "quotes", QUOTES }, // 712 - { "quote", QUOTES }, // 712 - { "random", RANDOM }, // 713 - { "random-seed", RANDOM_SEED }, // 714 - { "range", RANGE }, // 715 - { "raise", RAISE }, // 716 - { "raising", RAISING }, // 717 - { "rd", RD }, // 718 - { "record", RECORD }, // 719 - { "recording", RECORDING }, // 720 - { "records", RECORDS }, // 721 - { "recursive", RECURSIVE }, // 722 - { "redefines", REDEFINES }, // 723 - { "reel", REEL }, // 724 - { "reference", REFERENCE }, // 725 - { "relative", RELATIVE }, // 726 - { "rem", REM }, // 727 - { "remainder", REMAINDER }, // 728 - { "remarks", REMARKS }, // 729 - { "removal", REMOVAL }, // 730 - { "renames", RENAMES }, // 731 - { "replace", REPLACE }, // 732 - { "replacing", REPLACING }, // 733 - { "report", REPORT }, // 734 - { "reporting", REPORTING }, // 735 - { "reports", REPORTS }, // 736 - { "repository", REPOSITORY }, // 737 - { "rerun", RERUN }, // 738 - { "reserve", RESERVE }, // 739 - { "restricted", RESTRICTED }, // 740 - { "resume", RESUME }, // 741 - { "reverse", REVERSE }, // 742 - { "reversed", REVERSED }, // 743 - { "rewind", REWIND }, // 744 - { "rf", RF }, // 745 - { "rh", RH }, // 746 - { "right", RIGHT }, // 747 - { "rounded", ROUNDED }, // 748 - { "run", RUN }, // 749 - { "same", SAME }, // 750 - { "screen", SCREEN }, // 751 - { "sd", SD }, // 752 - { "seconds-from-formatted-time", SECONDS_FROM_FORMATTED_TIME }, // 753 - { "seconds-past-midnight", SECONDS_PAST_MIDNIGHT }, // 754 - { "security", SECURITY }, // 755 - { "separate", SEPARATE }, // 756 - { "sequence", SEQUENCE }, // 757 - { "sequential", SEQUENTIAL }, // 758 - { "sharing", SHARING }, // 759 - { "simple-exit", SIMPLE_EXIT }, // 760 - { "sign", SIGN }, // 761 - { "sin", SIN }, // 762 - { "size", SIZE }, // 763 - { "smallest-algebraic", SMALLEST_ALGEBRAIC }, // 764 - { "source", SOURCE }, // 765 - { "source-computer", SOURCE_COMPUTER }, // 766 - { "special-names", SPECIAL_NAMES }, // 767 - { "sqrt", SQRT }, // 768 - { "stack", STACK }, // 769 - { "standard", STANDARD }, // 770 - { "standard-1", STANDARD_1 }, // 771 - { "standard-deviation", STANDARD_DEVIATION }, // 772 - { "standard-compare", STANDARD_COMPARE }, // 773 - { "status", STATUS }, // 774 - { "strong", STRONG }, // 775 - { "substitute", SUBSTITUTE }, // 776 - { "sum", SUM }, // 777 - { "symbol", SYMBOL }, // 778 - { "symbolic", SYMBOLIC }, // 779 - { "synchronized", SYNCHRONIZED }, // 780 - { "tally", TALLY }, // 781 - { "tallying", TALLYING }, // 782 - { "tan", TAN }, // 783 - { "terminate", TERMINATE }, // 784 - { "test", TEST }, // 785 - { "test-date-yyyymmdd", TEST_DATE_YYYYMMDD }, // 786 - { "test-day-yyyyddd", TEST_DAY_YYYYDDD }, // 787 - { "test-formatted-datetime", TEST_FORMATTED_DATETIME }, // 788 - { "test-numval", TEST_NUMVAL }, // 789 - { "test-numval-c", TEST_NUMVAL_C }, // 790 - { "test-numval-f", TEST_NUMVAL_F }, // 791 - { "than", THAN }, // 792 - { "time", TIME }, // 793 - { "times", TIMES }, // 794 - { "to", TO }, // 795 - { "top", TOP }, // 796 - { "top-level", TOP_LEVEL }, // 797 - { "tracks", TRACKS }, // 798 - { "track-area", TRACK_AREA }, // 799 - { "trailing", TRAILING }, // 800 - { "transform", TRANSFORM }, // 801 - { "trim", TRIM }, // 802 - { "true", TRUE_kw }, // 803 - { "try", TRY }, // 804 - { "turn", TURN }, // 805 - { "type", TYPE }, // 806 - { "typedef", TYPEDEF }, // 807 - { "ulength", ULENGTH }, // 808 - { "unbounded", UNBOUNDED }, // 809 - { "unit", UNIT }, // 810 - { "units", UNITS }, // 811 - { "unit-record", UNIT_RECORD }, // 812 - { "until", UNTIL }, // 813 - { "up", UP }, // 814 - { "upon", UPON }, // 815 - { "upos", UPOS }, // 816 - { "upper-case", UPPER_CASE }, // 817 - { "usage", USAGE }, // 818 - { "using", USING }, // 819 - { "usubstr", USUBSTR }, // 820 - { "usupplementary", USUPPLEMENTARY }, // 821 - { "utility", UTILITY }, // 822 - { "uuid4", UUID4 }, // 823 - { "uvalid", UVALID }, // 824 - { "uwidth", UWIDTH }, // 825 - { "value", VALUE }, // 826 - { "variance", VARIANCE }, // 827 - { "varying", VARYING }, // 828 - { "volatile", VOLATILE }, // 829 - { "when-compiled", WHEN_COMPILED }, // 830 - { "with", WITH }, // 831 - { "working-storage", WORKING_STORAGE }, // 832 - { "xml", XML }, // 833 - { "xmlgenerate", XMLGENERATE }, // 834 - { "xmlparse", XMLPARSE }, // 835 - { "year-to-yyyy", YEAR_TO_YYYY }, // 836 - { "yyyyddd", YYYYDDD }, // 837 - { "yyyymmdd", YYYYMMDD }, // 838 - { "arithmetic", ARITHMETIC }, // 839 - { "attribute", ATTRIBUTE }, // 840 - { "auto", AUTO }, // 841 - { "automatic", AUTOMATIC }, // 842 - { "away-from-zero", AWAY_FROM_ZERO }, // 843 - { "background-color", BACKGROUND_COLOR }, // 844 - { "bell", BELL }, // 845 - { "binary-encoding", BINARY_ENCODING }, // 846 - { "blink", BLINK }, // 847 - { "capacity", CAPACITY }, // 848 - { "center", CENTER }, // 849 - { "classification", CLASSIFICATION }, // 850 - { "cycle", CYCLE }, // 851 - { "decimal-encoding", DECIMAL_ENCODING }, // 852 - { "entry-convention", ENTRY_CONVENTION }, // 853 - { "eol", EOL }, // 854 - { "eos", EOS }, // 855 - { "erase", ERASE }, // 856 - { "expands", EXPANDS }, // 857 - { "float-binary", FLOAT_BINARY }, // 858 - { "float-decimal", FLOAT_DECIMAL }, // 859 - { "foreground-color", FOREGROUND_COLOR }, // 860 - { "forever", FOREVER }, // 861 - { "full", FULL }, // 862 - { "highlight", HIGHLIGHT }, // 863 - { "high-order-left", HIGH_ORDER_LEFT }, // 864 - { "high-order-right", HIGH_ORDER_RIGHT }, // 865 - { "ignoring", IGNORING }, // 866 - { "implements", IMPLEMENTS }, // 867 - { "initialized", INITIALIZED }, // 868 - { "intermediate", INTERMEDIATE }, // 869 - { "lc-all", LC_ALL_kw }, // 870 - { "lc-collate", LC_COLLATE_kw }, // 871 - { "lc-ctype", LC_CTYPE_kw }, // 872 - { "lc-messages", LC_MESSAGES_kw }, // 873 - { "lc-monetary", LC_MONETARY_kw }, // 874 - { "lc-numeric", LC_NUMERIC_kw }, // 875 - { "lc-time", LC_TIME_kw }, // 876 - { "lowlight", LOWLIGHT }, // 877 - { "nearest-away-from-zero", NEAREST_AWAY_FROM_ZERO }, // 878 - { "nearest-even", NEAREST_EVEN }, // 879 - { "nearest-toward-zero", NEAREST_TOWARD_ZERO }, // 880 - { "none", NONE }, // 881 - { "normal", NORMAL }, // 882 - { "numbers", NUMBERS }, // 883 - { "prefixed", PREFIXED }, // 884 - { "previous", PREVIOUS }, // 885 - { "prohibited", PROHIBITED }, // 886 - { "relation", RELATION }, // 887 - { "required", REQUIRED }, // 888 - { "reverse-video", REVERSE_VIDEO }, // 889 - { "rounding", ROUNDING }, // 890 - { "seconds", SECONDS }, // 891 - { "secure", SECURE }, // 892 - { "short", SHORT }, // 893 - { "signed", SIGNED_kw }, // 894 - { "standard-binary", STANDARD_BINARY }, // 895 - { "standard-decimal", STANDARD_DECIMAL }, // 896 - { "statement", STATEMENT }, // 897 - { "step", STEP }, // 898 - { "structure", STRUCTURE }, // 899 - { "toward-greater", TOWARD_GREATER }, // 900 - { "toward-lesser", TOWARD_LESSER }, // 901 - { "truncation", TRUNCATION }, // 902 - { "ucs-4", UCS_4 }, // 903 - { "underline", UNDERLINE }, // 904 - { "unsigned", UNSIGNED_kw }, // 905 - { "utf-16", UTF_16 }, // 906 - { "utf-8", UTF_8 }, // 907 - { "address", ADDRESS }, // 908 - { "end-accept", END_ACCEPT }, // 909 - { "end-add", END_ADD }, // 910 - { "end-call", END_CALL }, // 911 - { "end-compute", END_COMPUTE }, // 912 - { "end-delete", END_DELETE }, // 913 - { "end-display", END_DISPLAY }, // 914 - { "end-divide", END_DIVIDE }, // 915 - { "end-evaluate", END_EVALUATE }, // 916 - { "end-multiply", END_MULTIPLY }, // 917 - { "end-perform", END_PERFORM }, // 918 - { "end-read", END_READ }, // 919 - { "end-return", END_RETURN }, // 920 - { "end-rewrite", END_REWRITE }, // 921 - { "end-search", END_SEARCH }, // 922 - { "end-start", END_START }, // 923 - { "end-string", END_STRING }, // 924 - { "end-subtract", END_SUBTRACT }, // 925 - { "end-unstring", END_UNSTRING }, // 926 - { "end-write", END_WRITE }, // 927 - { "end-if", END_IF }, // 928 - { "thru", THRU }, // 929 - { "through", THRU }, // 929 - { "or", OR }, // 930 - { "and", AND }, // 931 - { "not", NOT }, // 932 - { "ne", NE }, // 933 - { "le", LE }, // 934 - { "ge", GE }, // 935 - { "pow", POW }, // 936 - { "neg", NEG }, // 937 + { "identification", IDENTIFICATION_DIV }, // 258 + { "environment", ENVIRONMENT_DIV }, // 259 + { "procedure", PROCEDURE_DIV }, // 260 + { "data", DATA_DIV }, // 261 + { "file", FILE_SECT }, // 262 + { "input-output", INPUT_OUTPUT_SECT }, // 263 + { "linkage", LINKAGE_SECT }, // 264 + { "local-storage", LOCAL_STORAGE_SECT }, // 265 + { "working-storage", WORKING_STORAGE_SECT }, // 266 + { "object-computer", OBJECT_COMPUTER }, // 267 + { "display-of", DISPLAY_OF }, // 268 + { "end-function", END_FUNCTION }, // 269 + { "end-program", END_PROGRAM }, // 270 + { "end-subprogram", END_SUBPROGRAM }, // 271 + { "justified", JUSTIFIED }, // 272 + { "returning", RETURNING }, // 273 + { "no-condition", NO_CONDITION }, // 274 + { "alnum", ALNUM }, // 275 + { "alphed", ALPHED }, // 276 + { "error", ERROR }, // 277 + { "exception", EXCEPTION }, // 278 + { "size-error", SIZE_ERROR }, // 279 + { "exception-name", EXCEPTION_NAME }, // 280 + { "level", LEVEL }, // 281 + { "level66", LEVEL66 }, // 282 + { "level78", LEVEL78 }, // 283 + { "level88", LEVEL88 }, // 284 + { "class-name", CLASS_NAME }, // 285 + { "name", NAME }, // 286 + { "name88", NAME88 }, // 287 + { "nume", NUME }, // 288 + { "numed", NUMED }, // 289 + { "numed-cr", NUMED_CR }, // 290 + { "numed-db", NUMED_DB }, // 291 + { "ninedot", NINEDOT }, // 292 + { "nines", NINES }, // 293 + { "ninev", NINEV }, // 294 + { "pic-p", PIC_P }, // 295 + { "ones", ONES }, // 296 + { "spaces", SPACES }, // 297 + { "space", SPACES }, // 297 + { "literal", LITERAL }, // 298 + { "end", END }, // 299 + { "eop", EOP }, // 300 + { "filename", FILENAME }, // 301 + { "invalid", INVALID }, // 302 + { "number", NUMBER }, // 303 + { "negative", NEGATIVE }, // 304 + { "numstr", NUMSTR }, // 305 + { "overflow", OVERFLOW_kw }, // 306 + { "binary-integer", BINARY_INTEGER }, // 307 + { "computational", COMPUTATIONAL }, // 308 + { "perform", PERFORM }, // 309 + { "backward", BACKWARD }, // 310 + { "positive", POSITIVE }, // 311 + { "pointer", POINTER }, // 312 + { "section", SECTION }, // 313 + { "standard-alphabet", STANDARD_ALPHABET }, // 314 + { "switch", SWITCH }, // 315 + { "upsi", UPSI }, // 316 + { "zero", ZERO }, // 317 + { "zeros", ZERO }, // 317 + { "zeroes", ZERO }, // 317 + { "sysin", SYSIN }, // 318 + { "sysipt", SYSIPT }, // 319 + { "sysout", SYSOUT }, // 320 + { "syslist", SYSLIST }, // 321 + { "syslst", SYSLST }, // 322 + { "syspunch", SYSPUNCH }, // 323 + { "syspch", SYSPCH }, // 324 + { "console", CONSOLE }, // 325 + { "c01", C01 }, // 326 + { "c02", C02 }, // 327 + { "c03", C03 }, // 328 + { "c04", C04 }, // 329 + { "c05", C05 }, // 330 + { "c06", C06 }, // 331 + { "c07", C07 }, // 332 + { "c08", C08 }, // 333 + { "c09", C09 }, // 334 + { "c10", C10 }, // 335 + { "c11", C11 }, // 336 + { "c12", C12 }, // 337 + { "csp", CSP }, // 338 + { "s01", S01 }, // 339 + { "s02", S02 }, // 340 + { "s03", S03 }, // 341 + { "s04", S04 }, // 342 + { "s05", S05 }, // 343 + { "afp-5a", AFP_5A }, // 344 + { "stdin", STDIN }, // 345 + { "stdout", STDOUT }, // 346 + { "stderr", STDERR }, // 347 + { "list", LIST }, // 348 + { "map", MAP }, // 349 + { "nolist", NOLIST }, // 350 + { "nomap", NOMAP }, // 351 + { "nosource", NOSOURCE }, // 352 + { "might-be", MIGHT_BE }, // 353 + { "function-udf", FUNCTION_UDF }, // 354 + { "function-udf-0", FUNCTION_UDF_0 }, // 355 + { "date-fmt", DATE_FMT }, // 356 + { "time-fmt", TIME_FMT }, // 357 + { "datetime-fmt", DATETIME_FMT }, // 358 + { "basis", BASIS }, // 359 + { "cbl", CBL }, // 360 + { "constant", CONSTANT }, // 361 + { "copy", COPY }, // 362 + { "defined", DEFINED }, // 363 + { "enter", ENTER }, // 364 + { "feature", FEATURE }, // 365 + { "insertt", INSERTT }, // 366 + { "lsub", LSUB }, // 367 + { "parameter", PARAMETER_kw }, // 368 + { "override", OVERRIDE }, // 369 + { "ready", READY }, // 370 + { "reset", RESET }, // 371 + { "rsub", RSUB }, // 372 + { "service-reload", SERVICE_RELOAD }, // 373 + { "star-cbl", STAR_CBL }, // 374 + { "subscript", SUBSCRIPT }, // 375 + { "suppress", SUPPRESS }, // 376 + { "title", TITLE }, // 377 + { "trace", TRACE }, // 378 + { "use", USE }, // 379 + { "cobol-words", COBOL_WORDS }, // 380 + { "equate", EQUATE }, // 381 + { "undefine", UNDEFINE }, // 382 + { "cdf-define", CDF_DEFINE }, // 383 + { "cdf-display", CDF_DISPLAY }, // 384 + { "cdf-if", CDF_IF }, // 385 + { "cdf-else", CDF_ELSE }, // 386 + { "cdf-end-if", CDF_END_IF }, // 387 + { "cdf-evaluate", CDF_EVALUATE }, // 388 + { "cdf-when", CDF_WHEN }, // 389 + { "cdf-end-evaluate", CDF_END_EVALUATE }, // 390 + { "call-cobol", CALL_COBOL }, // 391 + { "call-verbatim", CALL_VERBATIM }, // 392 + { "if", IF }, // 393 + { "then", THEN }, // 394 + { "else", ELSE }, // 395 + { "sentence", SENTENCE }, // 396 + { "accept", ACCEPT }, // 397 + { "add", ADD }, // 398 + { "alter", ALTER }, // 399 + { "call", CALL }, // 400 + { "cancel", CANCEL }, // 401 + { "close", CLOSE }, // 402 + { "compute", COMPUTE }, // 403 + { "continue", CONTINUE }, // 404 + { "delete", DELETE }, // 405 + { "display", DISPLAY }, // 406 + { "divide", DIVIDE }, // 407 + { "evaluate", EVALUATE }, // 408 + { "exit", EXIT }, // 409 + { "filler", FILLER_kw }, // 410 + { "goback", GOBACK }, // 411 + { "goto", GOTO }, // 412 + { "initialize", INITIALIZE }, // 413 + { "inspect", INSPECT }, // 414 + { "merge", MERGE }, // 415 + { "move", MOVE }, // 416 + { "multiply", MULTIPLY }, // 417 + { "open", OPEN }, // 418 + { "paragraph", PARAGRAPH }, // 419 + { "read", READ }, // 420 + { "release", RELEASE }, // 421 + { "return", RETURN }, // 422 + { "rewrite", REWRITE }, // 423 + { "search", SEARCH }, // 424 + { "set", SET }, // 425 + { "select", SELECT }, // 426 + { "sort", SORT }, // 427 + { "sort-merge", SORT_MERGE }, // 428 + { "string", STRING_kw }, // 429 + { "stop", STOP }, // 430 + { "subtract", SUBTRACT }, // 431 + { "start", START }, // 432 + { "unstring", UNSTRING }, // 433 + { "write", WRITE }, // 434 + { "when", WHEN }, // 435 + { "abs", ABS }, // 436 + { "access", ACCESS }, // 437 + { "acos", ACOS }, // 438 + { "actual", ACTUAL }, // 439 + { "advancing", ADVANCING }, // 440 + { "after", AFTER }, // 441 + { "all", ALL }, // 442 + { "allocate", ALLOCATE }, // 443 + { "alphabet", ALPHABET }, // 444 + { "alphabetic", ALPHABETIC }, // 445 + { "alphabetic-lower", ALPHABETIC_LOWER }, // 446 + { "alphabetic-upper", ALPHABETIC_UPPER }, // 447 + { "alphanumeric", ALPHANUMERIC }, // 448 + { "alphanumeric-edited", ALPHANUMERIC_EDITED }, // 449 + { "also", ALSO }, // 450 + { "alternate", ALTERNATE }, // 451 + { "annuity", ANNUITY }, // 452 + { "anum", ANUM }, // 453 + { "any", ANY }, // 454 + { "anycase", ANYCASE }, // 455 + { "apply", APPLY }, // 456 + { "are", ARE }, // 457 + { "area", AREA }, // 458 + { "areas", AREAS }, // 459 + { "as", AS }, // 460 + { "ascending", ASCENDING }, // 461 + { "activating", ACTIVATING }, // 462 + { "asin", ASIN }, // 463 + { "assign", ASSIGN }, // 464 + { "at", AT }, // 465 + { "atan", ATAN }, // 466 + { "based", BASED }, // 467 + { "baseconvert", BASECONVERT }, // 468 + { "before", BEFORE }, // 469 + { "binary", BINARY }, // 470 + { "bit", BIT }, // 471 + { "bit-of", BIT_OF }, // 472 + { "bit-to-char", BIT_TO_CHAR }, // 473 + { "blank", BLANK }, // 474 + { "block", BLOCK_kw }, // 475 + { "boolean-of-integer", BOOLEAN_OF_INTEGER }, // 476 + { "bottom", BOTTOM }, // 477 + { "by", BY }, // 478 + { "byte", BYTE }, // 479 + { "byte-length", BYTE_LENGTH }, // 480 + { "cf", CF }, // 481 + { "ch", CH }, // 482 + { "changed", CHANGED }, // 483 + { "char", CHAR }, // 484 + { "char-national", CHAR_NATIONAL }, // 485 + { "character", CHARACTER }, // 486 + { "characters", CHARACTERS }, // 487 + { "checking", CHECKING }, // 488 + { "class", CLASS }, // 489 + { "cobol", COBOL }, // 490 + { "code", CODE }, // 491 + { "code-set", CODESET }, // 492 + { "collating", COLLATING }, // 493 + { "column", COLUMN }, // 494 + { "combined-datetime", COMBINED_DATETIME }, // 495 + { "comma", COMMA }, // 496 + { "command-line", COMMAND_LINE }, // 497 + { "command-line-count", COMMAND_LINE_COUNT }, // 498 + { "commit", COMMIT }, // 499 + { "common", COMMON }, // 500 + { "concat", CONCAT }, // 501 + { "condition", CONDITION }, // 502 + { "configuration", CONFIGURATION_SECT }, // 503 + { "contains", CONTAINS }, // 504 + { "content", CONTENT }, // 505 + { "control", CONTROL }, // 506 + { "controls", CONTROLS }, // 507 + { "convert", CONVERT }, // 508 + { "converting", CONVERTING }, // 509 + { "corresponding", CORRESPONDING }, // 510 + { "cos", COS }, // 511 + { "count", COUNT }, // 512 + { "currency", CURRENCY }, // 513 + { "current", CURRENT }, // 514 + { "current-date", CURRENT_DATE }, // 515 + { "data", DATA }, // 516 + { "date", DATE }, // 517 + { "date-compiled", DATE_COMPILED }, // 518 + { "date-of-integer", DATE_OF_INTEGER }, // 519 + { "date-to-yyyymmdd", DATE_TO_YYYYMMDD }, // 520 + { "date-written", DATE_WRITTEN }, // 521 + { "day", DAY }, // 522 + { "day-of-integer", DAY_OF_INTEGER }, // 523 + { "day-of-week", DAY_OF_WEEK }, // 524 + { "day-to-yyyyddd", DAY_TO_YYYYDDD }, // 525 + { "dbcs", DBCS }, // 526 + { "de", DE }, // 527 + { "debugging", DEBUGGING }, // 528 + { "decimal-point", DECIMAL_POINT }, // 529 + { "declaratives", DECLARATIVES }, // 530 + { "default", DEFAULT }, // 531 + { "delimited", DELIMITED }, // 532 + { "delimiter", DELIMITER }, // 533 + { "depending", DEPENDING }, // 534 + { "descending", DESCENDING }, // 535 + { "detail", DETAIL }, // 536 + { "direct", DIRECT }, // 537 + { "direct-access", DIRECT_ACCESS }, // 538 + { "down", DOWN }, // 539 + { "duplicates", DUPLICATES }, // 540 + { "dynamic", DYNAMIC }, // 541 + { "e", E }, // 542 + { "ebcdic", EBCDIC }, // 543 + { "ec", EC }, // 544 + { "egcs", EGCS }, // 545 + { "entry", ENTRY }, // 546 + { "environment", ENVIRONMENT }, // 547 + { "equal", EQUAL }, // 548 + { "every", EVERY }, // 549 + { "examine", EXAMINE }, // 550 + { "exhibit", EXHIBIT }, // 551 + { "exp", EXP }, // 552 + { "exp10", EXP10 }, // 553 + { "extend", EXTEND }, // 554 + { "external", EXTERNAL }, // 555 + { "exception-file", EXCEPTION_FILE }, // 556 + { "exception-file-n", EXCEPTION_FILE_N }, // 557 + { "exception-location", EXCEPTION_LOCATION }, // 558 + { "exception-location-n", EXCEPTION_LOCATION_N }, // 559 + { "exception-statement", EXCEPTION_STATEMENT }, // 560 + { "exception-status", EXCEPTION_STATUS }, // 561 + { "factorial", FACTORIAL }, // 562 + { "false", FALSE_kw }, // 563 + { "fd", FD }, // 564 + { "file-control", FILE_CONTROL }, // 565 + { "file", FILE_KW }, // 566 + { "file-limit", FILE_LIMIT }, // 567 + { "final", FINAL }, // 568 + { "finally", FINALLY }, // 569 + { "find-string", FIND_STRING }, // 570 + { "first", FIRST }, // 571 + { "fixed", FIXED }, // 572 + { "footing", FOOTING }, // 573 + { "for", FOR }, // 574 + { "formatted-current-date", FORMATTED_CURRENT_DATE }, // 575 + { "formatted-date", FORMATTED_DATE }, // 576 + { "formatted-datetime", FORMATTED_DATETIME }, // 577 + { "formatted-time", FORMATTED_TIME }, // 578 + { "form-overflow", FORM_OVERFLOW }, // 579 + { "free", FREE }, // 580 + { "fraction-part", FRACTION_PART }, // 581 + { "from", FROM }, // 582 + { "function", FUNCTION }, // 583 + { "generate", GENERATE }, // 584 + { "giving", GIVING }, // 585 + { "global", GLOBAL }, // 586 + { "go", GO }, // 587 + { "group", GROUP }, // 588 + { "heading", HEADING }, // 589 + { "hex", HEX }, // 590 + { "hex-of", HEX_OF }, // 591 + { "hex-to-char", HEX_TO_CHAR }, // 592 + { "high-values", HIGH_VALUES }, // 593 + { "highest-algebraic", HIGHEST_ALGEBRAIC }, // 594 + { "hold", HOLD }, // 595 + { "ibm-360", IBM_360 }, // 596 + { "in", IN }, // 597 + { "include", INCLUDE }, // 598 + { "index", INDEX }, // 599 + { "indexed", INDEXED }, // 600 + { "indicate", INDICATE }, // 601 + { "initial", INITIAL_kw }, // 602 + { "initiate", INITIATE }, // 603 + { "input", INPUT }, // 604 + { "installation", INSTALLATION }, // 605 + { "interface", INTERFACE }, // 606 + { "integer", INTEGER }, // 607 + { "integer-of-boolean", INTEGER_OF_BOOLEAN }, // 608 + { "integer-of-date", INTEGER_OF_DATE }, // 609 + { "integer-of-day", INTEGER_OF_DAY }, // 610 + { "integer-of-formatted-date", INTEGER_OF_FORMATTED_DATE }, // 611 + { "integer-part", INTEGER_PART }, // 612 + { "into", INTO }, // 613 + { "intrinsic", INTRINSIC }, // 614 + { "invoke", INVOKE }, // 615 + { "i-o", IO }, // 616 + { "i-o-control", IO_CONTROL }, // 617 + { "is", IS }, // 618 + { "isnt", ISNT }, // 619 + { "kanji", KANJI }, // 620 + { "key", KEY }, // 621 + { "label", LABEL }, // 622 + { "last", LAST }, // 623 + { "leading", LEADING }, // 624 + { "left", LEFT }, // 625 + { "length", LENGTH }, // 626 + { "length-of", LENGTH_OF }, // 627 + { "limit", LIMIT }, // 628 + { "limits", LIMITS }, // 629 + { "line", LINE }, // 630 + { "lines", LINES }, // 631 + { "line-counter", LINE_COUNTER }, // 632 + { "linage", LINAGE }, // 633 + { "linkage", LINKAGE }, // 634 + { "locale", LOCALE }, // 635 + { "locale-compare", LOCALE_COMPARE }, // 636 + { "locale-date", LOCALE_DATE }, // 637 + { "locale-time", LOCALE_TIME }, // 638 + { "locale-time-from-seconds", LOCALE_TIME_FROM_SECONDS }, // 639 + { "local-storage", LOCAL_STORAGE }, // 640 + { "location", LOCATION }, // 641 + { "lock", LOCK }, // 642 + { "lock-on", LOCK_ON }, // 643 + { "log", LOG }, // 644 + { "log10", LOG10 }, // 645 + { "lower-case", LOWER_CASE }, // 646 + { "low-values", LOW_VALUES }, // 647 + { "lowest-algebraic", LOWEST_ALGEBRAIC }, // 648 + { "lparen", LPAREN }, // 649 + { "manual", MANUAL }, // 650 + { "maxx", MAXX }, // 651 + { "mean", MEAN }, // 652 + { "median", MEDIAN }, // 653 + { "midrange", MIDRANGE }, // 654 + { "minn", MINN }, // 655 + { "multiple", MULTIPLE }, // 656 + { "mod", MOD }, // 657 + { "mode", MODE }, // 658 + { "module-name", MODULE_NAME }, // 659 + { "named", NAMED }, // 660 + { "nat", NAT }, // 661 + { "national", NATIONAL }, // 662 + { "national-edited", NATIONAL_EDITED }, // 663 + { "national-of", NATIONAL_OF }, // 664 + { "native", NATIVE }, // 665 + { "nested", NESTED }, // 666 + { "next", NEXT }, // 667 + { "no", NO }, // 668 + { "note", NOTE }, // 669 + { "nulls", NULLS }, // 670 + { "null", NULLS }, // 670 + { "nullptr", NULLPTR }, // 671 + { "numeric", NUMERIC }, // 672 + { "numeric-edited", NUMERIC_EDITED }, // 673 + { "numval", NUMVAL }, // 674 + { "numval-c", NUMVAL_C }, // 675 + { "numval-f", NUMVAL_F }, // 676 + { "occurs", OCCURS }, // 677 + { "of", OF }, // 678 + { "off", OFF }, // 679 + { "omitted", OMITTED }, // 680 + { "on", ON }, // 681 + { "only", ONLY }, // 682 + { "optional", OPTIONAL }, // 683 + { "options", OPTIONS }, // 684 + { "ord", ORD }, // 685 + { "order", ORDER }, // 686 + { "ord-max", ORD_MAX }, // 687 + { "ord-min", ORD_MIN }, // 688 + { "organization", ORGANIZATION }, // 689 + { "other", OTHER }, // 690 + { "otherwise", OTHERWISE }, // 691 + { "output", OUTPUT }, // 692 + { "packed-decimal", PACKED_DECIMAL }, // 693 + { "padding", PADDING }, // 694 + { "page", PAGE }, // 695 + { "page-counter", PAGE_COUNTER }, // 696 + { "pf", PF }, // 697 + { "ph", PH }, // 698 + { "pi", PI }, // 699 + { "pic", PIC }, // 700 + { "picture", PICTURE }, // 701 + { "plus", PLUS }, // 702 + { "present-value", PRESENT_VALUE }, // 703 + { "print-switch", PRINT_SWITCH }, // 704 + { "procedure", PROCEDURE }, // 705 + { "procedures", PROCEDURES }, // 706 + { "proceed", PROCEED }, // 707 + { "process", PROCESS }, // 708 + { "program-id", PROGRAM_ID }, // 709 + { "program", PROGRAM_kw }, // 710 + { "property", PROPERTY }, // 711 + { "prototype", PROTOTYPE }, // 712 + { "pseudotext", PSEUDOTEXT }, // 713 + { "quotes", QUOTES }, // 714 + { "quote", QUOTES }, // 714 + { "random", RANDOM }, // 715 + { "random-seed", RANDOM_SEED }, // 716 + { "range", RANGE }, // 717 + { "raise", RAISE }, // 718 + { "raising", RAISING }, // 719 + { "rd", RD }, // 720 + { "record", RECORD }, // 721 + { "recording", RECORDING }, // 722 + { "records", RECORDS }, // 723 + { "recursive", RECURSIVE }, // 724 + { "redefines", REDEFINES }, // 725 + { "reel", REEL }, // 726 + { "reference", REFERENCE }, // 727 + { "relative", RELATIVE }, // 728 + { "rem", REM }, // 729 + { "remainder", REMAINDER }, // 730 + { "remarks", REMARKS }, // 731 + { "removal", REMOVAL }, // 732 + { "renames", RENAMES }, // 733 + { "replace", REPLACE }, // 734 + { "replacing", REPLACING }, // 735 + { "report", REPORT }, // 736 + { "reporting", REPORTING }, // 737 + { "reports", REPORTS }, // 738 + { "repository", REPOSITORY }, // 739 + { "rerun", RERUN }, // 740 + { "reserve", RESERVE }, // 741 + { "restricted", RESTRICTED }, // 742 + { "resume", RESUME }, // 743 + { "reverse", REVERSE }, // 744 + { "reversed", REVERSED }, // 745 + { "rewind", REWIND }, // 746 + { "rf", RF }, // 747 + { "rh", RH }, // 748 + { "right", RIGHT }, // 749 + { "rounded", ROUNDED }, // 750 + { "run", RUN }, // 751 + { "same", SAME }, // 752 + { "screen", SCREEN }, // 753 + { "sd", SD }, // 754 + { "seconds-from-formatted-time", SECONDS_FROM_FORMATTED_TIME }, // 755 + { "seconds-past-midnight", SECONDS_PAST_MIDNIGHT }, // 756 + { "security", SECURITY }, // 757 + { "separate", SEPARATE }, // 758 + { "sequence", SEQUENCE }, // 759 + { "sequential", SEQUENTIAL }, // 760 + { "sharing", SHARING }, // 761 + { "simple-exit", SIMPLE_EXIT }, // 762 + { "sign", SIGN }, // 763 + { "sin", SIN }, // 764 + { "size", SIZE }, // 765 + { "smallest-algebraic", SMALLEST_ALGEBRAIC }, // 766 + { "source", SOURCE }, // 767 + { "source-computer", SOURCE_COMPUTER }, // 768 + { "special-names", SPECIAL_NAMES }, // 769 + { "sqrt", SQRT }, // 770 + { "stack", STACK }, // 771 + { "standard", STANDARD }, // 772 + { "standard-1", STANDARD_1 }, // 773 + { "standard-deviation", STANDARD_DEVIATION }, // 774 + { "standard-compare", STANDARD_COMPARE }, // 775 + { "status", STATUS }, // 776 + { "strong", STRONG }, // 777 + { "substitute", SUBSTITUTE }, // 778 + { "sum", SUM }, // 779 + { "symbol", SYMBOL }, // 780 + { "symbolic", SYMBOLIC }, // 781 + { "synchronized", SYNCHRONIZED }, // 782 + { "tally", TALLY }, // 783 + { "tallying", TALLYING }, // 784 + { "tan", TAN }, // 785 + { "terminate", TERMINATE }, // 786 + { "test", TEST }, // 787 + { "test-date-yyyymmdd", TEST_DATE_YYYYMMDD }, // 788 + { "test-day-yyyyddd", TEST_DAY_YYYYDDD }, // 789 + { "test-formatted-datetime", TEST_FORMATTED_DATETIME }, // 790 + { "test-numval", TEST_NUMVAL }, // 791 + { "test-numval-c", TEST_NUMVAL_C }, // 792 + { "test-numval-f", TEST_NUMVAL_F }, // 793 + { "than", THAN }, // 794 + { "time", TIME }, // 795 + { "times", TIMES }, // 796 + { "to", TO }, // 797 + { "top", TOP }, // 798 + { "top-level", TOP_LEVEL }, // 799 + { "tracks", TRACKS }, // 800 + { "track-area", TRACK_AREA }, // 801 + { "trailing", TRAILING }, // 802 + { "transform", TRANSFORM }, // 803 + { "trim", TRIM }, // 804 + { "true", TRUE_kw }, // 805 + { "try", TRY }, // 806 + { "turn", TURN }, // 807 + { "type", TYPE }, // 808 + { "typedef", TYPEDEF }, // 809 + { "ulength", ULENGTH }, // 810 + { "unbounded", UNBOUNDED }, // 811 + { "unit", UNIT }, // 812 + { "units", UNITS }, // 813 + { "unit-record", UNIT_RECORD }, // 814 + { "until", UNTIL }, // 815 + { "up", UP }, // 816 + { "upon", UPON }, // 817 + { "upos", UPOS }, // 818 + { "upper-case", UPPER_CASE }, // 819 + { "usage", USAGE }, // 820 + { "using", USING }, // 821 + { "usubstr", USUBSTR }, // 822 + { "usupplementary", USUPPLEMENTARY }, // 823 + { "utility", UTILITY }, // 824 + { "uuid4", UUID4 }, // 825 + { "uvalid", UVALID }, // 826 + { "uwidth", UWIDTH }, // 827 + { "value", VALUE }, // 828 + { "variance", VARIANCE }, // 829 + { "varying", VARYING }, // 830 + { "volatile", VOLATILE }, // 831 + { "when-compiled", WHEN_COMPILED }, // 832 + { "with", WITH }, // 833 + { "working-storage", WORKING_STORAGE }, // 834 + { "xml", XML }, // 835 + { "xmlgenerate", XMLGENERATE }, // 836 + { "xmlparse", XMLPARSE }, // 837 + { "year-to-yyyy", YEAR_TO_YYYY }, // 838 + { "yyyyddd", YYYYDDD }, // 839 + { "yyyymmdd", YYYYMMDD }, // 840 + { "arithmetic", ARITHMETIC }, // 841 + { "attribute", ATTRIBUTE }, // 842 + { "auto", AUTO }, // 843 + { "automatic", AUTOMATIC }, // 844 + { "away-from-zero", AWAY_FROM_ZERO }, // 845 + { "background-color", BACKGROUND_COLOR }, // 846 + { "bell", BELL }, // 847 + { "binary-encoding", BINARY_ENCODING }, // 848 + { "blink", BLINK }, // 849 + { "capacity", CAPACITY }, // 850 + { "center", CENTER }, // 851 + { "classification", CLASSIFICATION }, // 852 + { "cycle", CYCLE }, // 853 + { "decimal-encoding", DECIMAL_ENCODING }, // 854 + { "entry-convention", ENTRY_CONVENTION }, // 855 + { "eol", EOL }, // 856 + { "eos", EOS }, // 857 + { "erase", ERASE }, // 858 + { "expands", EXPANDS }, // 859 + { "float-binary", FLOAT_BINARY }, // 860 + { "float-decimal", FLOAT_DECIMAL }, // 861 + { "foreground-color", FOREGROUND_COLOR }, // 862 + { "forever", FOREVER }, // 863 + { "full", FULL }, // 864 + { "highlight", HIGHLIGHT }, // 865 + { "high-order-left", HIGH_ORDER_LEFT }, // 866 + { "high-order-right", HIGH_ORDER_RIGHT }, // 867 + { "ignoring", IGNORING }, // 868 + { "implements", IMPLEMENTS }, // 869 + { "initialized", INITIALIZED }, // 870 + { "intermediate", INTERMEDIATE }, // 871 + { "lc-all", LC_ALL_kw }, // 872 + { "lc-collate", LC_COLLATE_kw }, // 873 + { "lc-ctype", LC_CTYPE_kw }, // 874 + { "lc-messages", LC_MESSAGES_kw }, // 875 + { "lc-monetary", LC_MONETARY_kw }, // 876 + { "lc-numeric", LC_NUMERIC_kw }, // 877 + { "lc-time", LC_TIME_kw }, // 878 + { "lowlight", LOWLIGHT }, // 879 + { "nearest-away-from-zero", NEAREST_AWAY_FROM_ZERO }, // 880 + { "nearest-even", NEAREST_EVEN }, // 881 + { "nearest-toward-zero", NEAREST_TOWARD_ZERO }, // 882 + { "none", NONE }, // 883 + { "normal", NORMAL }, // 884 + { "numbers", NUMBERS }, // 885 + { "prefixed", PREFIXED }, // 886 + { "previous", PREVIOUS }, // 887 + { "prohibited", PROHIBITED }, // 888 + { "relation", RELATION }, // 889 + { "required", REQUIRED }, // 890 + { "reverse-video", REVERSE_VIDEO }, // 891 + { "rounding", ROUNDING }, // 892 + { "seconds", SECONDS }, // 893 + { "secure", SECURE }, // 894 + { "short", SHORT }, // 895 + { "signed", SIGNED_kw }, // 896 + { "standard-binary", STANDARD_BINARY }, // 897 + { "standard-decimal", STANDARD_DECIMAL }, // 898 + { "statement", STATEMENT }, // 899 + { "step", STEP }, // 900 + { "structure", STRUCTURE }, // 901 + { "toward-greater", TOWARD_GREATER }, // 902 + { "toward-lesser", TOWARD_LESSER }, // 903 + { "truncation", TRUNCATION }, // 904 + { "ucs-4", UCS_4 }, // 905 + { "underline", UNDERLINE }, // 906 + { "unsigned", UNSIGNED_kw }, // 907 + { "utf-16", UTF_16 }, // 908 + { "utf-8", UTF_8 }, // 909 + { "address", ADDRESS }, // 910 + { "end-accept", END_ACCEPT }, // 911 + { "end-add", END_ADD }, // 912 + { "end-call", END_CALL }, // 913 + { "end-compute", END_COMPUTE }, // 914 + { "end-delete", END_DELETE }, // 915 + { "end-display", END_DISPLAY }, // 916 + { "end-divide", END_DIVIDE }, // 917 + { "end-evaluate", END_EVALUATE }, // 918 + { "end-multiply", END_MULTIPLY }, // 919 + { "end-perform", END_PERFORM }, // 920 + { "end-read", END_READ }, // 921 + { "end-return", END_RETURN }, // 922 + { "end-rewrite", END_REWRITE }, // 923 + { "end-search", END_SEARCH }, // 924 + { "end-start", END_START }, // 925 + { "end-string", END_STRING }, // 926 + { "end-subtract", END_SUBTRACT }, // 927 + { "end-unstring", END_UNSTRING }, // 928 + { "end-write", END_WRITE }, // 929 + { "end-if", END_IF }, // 930 + { "thru", THRU }, // 931 + { "through", THRU }, // 931 + { "or", OR }, // 932 + { "and", AND }, // 933 + { "not", NOT }, // 934 + { "ne", NE }, // 935 + { "le", LE }, // 936 + { "ge", GE }, // 937 + { "pow", POW }, // 938 + { "neg", NEG }, // 939 }; +// cppcheck-suppress useInitializationList token_names = { - "IDENTIFICATION", // 0 (258) - "ENVIRONMENT", // 1 (259) - "PROCEDURE", // 2 (260) - "DATA", // 3 (261) - "FILE", // 4 (262) - "INPUT-OUTPUT", // 5 (263) - "LINKAGE", // 6 (264) - "LOCAL-STORAGE", // 7 (265) - "WORKING-STORAGE", // 8 (266) - "OBJECT-COMPUTER", // 9 (267) - "DISPLAY-OF", // 10 (268) - "END-FUNCTION", // 11 (269) - "END-PROGRAM", // 12 (270) - "END-SUBPROGRAM", // 13 (271) - "JUSTIFIED", // 14 (272) - "RETURNING", // 15 (273) - "NO-CONDITION", // 16 (274) - "ALNUM", // 17 (275) - "ALPHED", // 18 (276) - "ERROR", // 19 (277) - "EXCEPTION", // 20 (278) - "SIZE-ERROR", // 21 (279) - "EXCEPTION-NAME", // 22 (280) - "LEVEL", // 23 (281) - "LEVEL66", // 24 (282) - "LEVEL78", // 25 (283) - "LEVEL88", // 26 (284) - "CLASS-NAME", // 27 (285) - "NAME", // 28 (286) - "NAME88", // 29 (287) - "NUME", // 30 (288) - "NUMED", // 31 (289) - "NUMED-CR", // 32 (290) - "NUMED-DB", // 33 (291) - "NINEDOT", // 34 (292) - "NINES", // 35 (293) - "NINEV", // 36 (294) - "PIC-P", // 37 (295) - "SPACES", // 38 (296) - "LITERAL", // 39 (297) - "END", // 40 (298) - "EOP", // 41 (299) - "FILENAME", // 42 (300) - "INVALID", // 43 (301) - "NUMBER", // 44 (302) - "NEGATIVE", // 45 (303) - "NUMSTR", // 46 (304) - "OVERFLOW", // 47 (305) - "COMPUTATIONAL", // 48 (306) - "PERFORM", // 49 (307) - "BACKWARD", // 50 (308) - "POSITIVE", // 51 (309) - "POINTER", // 52 (310) - "SECTION", // 53 (311) - "STANDARD-ALPHABET", // 54 (312) - "SWITCH", // 55 (313) - "UPSI", // 56 (314) - "ZERO", // 57 (315) - "SYSIN", // 58 (316) - "SYSIPT", // 59 (317) - "SYSOUT", // 60 (318) - "SYSLIST", // 61 (319) - "SYSLST", // 62 (320) - "SYSPUNCH", // 63 (321) - "SYSPCH", // 64 (322) - "CONSOLE", // 65 (323) - "C01", // 66 (324) - "C02", // 67 (325) - "C03", // 68 (326) - "C04", // 69 (327) - "C05", // 70 (328) - "C06", // 71 (329) - "C07", // 72 (330) - "C08", // 73 (331) - "C09", // 74 (332) - "C10", // 75 (333) - "C11", // 76 (334) - "C12", // 77 (335) - "CSP", // 78 (336) - "S01", // 79 (337) - "S02", // 80 (338) - "S03", // 81 (339) - "S04", // 82 (340) - "S05", // 83 (341) - "AFP-5A", // 84 (342) - "STDIN", // 85 (343) - "STDOUT", // 86 (344) - "STDERR", // 87 (345) - "LIST", // 88 (346) - "MAP", // 89 (347) - "NOLIST", // 90 (348) - "NOMAP", // 91 (349) - "NOSOURCE", // 92 (350) - "MIGHT-BE", // 93 (351) - "FUNCTION-UDF", // 94 (352) - "FUNCTION-UDF-0", // 95 (353) - "DATE-FMT", // 96 (354) - "TIME-FMT", // 97 (355) - "DATETIME-FMT", // 98 (356) - "BASIS", // 99 (357) - "CBL", // 100 (358) - "CONSTANT", // 101 (359) - "COPY", // 102 (360) - "DEFINED", // 103 (361) - "ENTER", // 104 (362) - "FEATURE", // 105 (363) - "INSERTT", // 106 (364) - "LSUB", // 107 (365) - "PARAMETER", // 108 (366) - "OVERRIDE", // 109 (367) - "READY", // 110 (368) - "RESET", // 111 (369) - "RSUB", // 112 (370) - "SERVICE-RELOAD", // 113 (371) - "STAR-CBL", // 114 (372) - "SUBSCRIPT", // 115 (373) - "SUPPRESS", // 116 (374) - "TITLE", // 117 (375) - "TRACE", // 118 (376) - "USE", // 119 (377) - "COBOL-WORDS", // 120 (378) - "EQUATE", // 121 (379) - "UNDEFINE", // 122 (380) - "CDF-DEFINE", // 123 (381) - "CDF-DISPLAY", // 124 (382) - "CDF-IF", // 125 (383) - "CDF-ELSE", // 126 (384) - "CDF-END-IF", // 127 (385) - "CDF-EVALUATE", // 128 (386) - "CDF-WHEN", // 129 (387) - "CDF-END-EVALUATE", // 130 (388) - "CALL-COBOL", // 131 (389) - "CALL-VERBATIM", // 132 (390) - "IF", // 133 (391) - "THEN", // 134 (392) - "ELSE", // 135 (393) - "SENTENCE", // 136 (394) - "ACCEPT", // 137 (395) - "ADD", // 138 (396) - "ALTER", // 139 (397) - "CALL", // 140 (398) - "CANCEL", // 141 (399) - "CLOSE", // 142 (400) - "COMPUTE", // 143 (401) - "CONTINUE", // 144 (402) - "DELETE", // 145 (403) - "DISPLAY", // 146 (404) - "DIVIDE", // 147 (405) - "EVALUATE", // 148 (406) - "EXIT", // 149 (407) - "FILLER", // 150 (408) - "GOBACK", // 151 (409) - "GOTO", // 152 (410) - "INITIALIZE", // 153 (411) - "INSPECT", // 154 (412) - "MERGE", // 155 (413) - "MOVE", // 156 (414) - "MULTIPLY", // 157 (415) - "OPEN", // 158 (416) - "PARAGRAPH", // 159 (417) - "READ", // 160 (418) - "RELEASE", // 161 (419) - "RETURN", // 162 (420) - "REWRITE", // 163 (421) - "SEARCH", // 164 (422) - "SET", // 165 (423) - "SELECT", // 166 (424) - "SORT", // 167 (425) - "SORT-MERGE", // 168 (426) - "STRING", // 169 (427) - "STOP", // 170 (428) - "SUBTRACT", // 171 (429) - "START", // 172 (430) - "UNSTRING", // 173 (431) - "WRITE", // 174 (432) - "WHEN", // 175 (433) - "ABS", // 176 (434) - "ACCESS", // 177 (435) - "ACOS", // 178 (436) - "ACTUAL", // 179 (437) - "ADVANCING", // 180 (438) - "AFTER", // 181 (439) - "ALL", // 182 (440) - "ALLOCATE", // 183 (441) - "ALPHABET", // 184 (442) - "ALPHABETIC", // 185 (443) - "ALPHABETIC-LOWER", // 186 (444) - "ALPHABETIC-UPPER", // 187 (445) - "ALPHANUMERIC", // 188 (446) - "ALPHANUMERIC-EDITED", // 189 (447) - "ALSO", // 190 (448) - "ALTERNATE", // 191 (449) - "ANNUITY", // 192 (450) - "ANUM", // 193 (451) - "ANY", // 194 (452) - "ANYCASE", // 195 (453) - "APPLY", // 196 (454) - "ARE", // 197 (455) - "AREA", // 198 (456) - "AREAS", // 199 (457) - "AS", // 200 (458) - "ASCENDING", // 201 (459) - "ACTIVATING", // 202 (460) - "ASIN", // 203 (461) - "ASSIGN", // 204 (462) - "AT", // 205 (463) - "ATAN", // 206 (464) - "BASED", // 207 (465) - "BASECONVERT", // 208 (466) - "BEFORE", // 209 (467) - "BINARY", // 210 (468) - "BIT", // 211 (469) - "BIT-OF", // 212 (470) - "BIT-TO-CHAR", // 213 (471) - "BLANK", // 214 (472) - "BLOCK", // 215 (473) - "BOOLEAN-OF-INTEGER", // 216 (474) - "BOTTOM", // 217 (475) - "BY", // 218 (476) - "BYTE", // 219 (477) - "BYTE-LENGTH", // 220 (478) - "CF", // 221 (479) - "CH", // 222 (480) - "CHANGED", // 223 (481) - "CHAR", // 224 (482) - "CHAR-NATIONAL", // 225 (483) - "CHARACTER", // 226 (484) - "CHARACTERS", // 227 (485) - "CHECKING", // 228 (486) - "CLASS", // 229 (487) - "COBOL", // 230 (488) - "CODE", // 231 (489) - "CODE-SET", // 232 (490) - "COLLATING", // 233 (491) - "COLUMN", // 234 (492) - "COMBINED-DATETIME", // 235 (493) - "COMMA", // 236 (494) - "COMMAND-LINE", // 237 (495) - "COMMAND-LINE-COUNT", // 238 (496) - "COMMIT", // 239 (497) - "COMMON", // 240 (498) - "CONCAT", // 241 (499) - "CONDITION", // 242 (500) - "CONFIGURATION", // 243 (501) - "CONTAINS", // 244 (502) - "CONTENT", // 245 (503) - "CONTROL", // 246 (504) - "CONTROLS", // 247 (505) - "CONVERT", // 248 (506) - "CONVERTING", // 249 (507) - "CORRESPONDING", // 250 (508) - "COS", // 251 (509) - "COUNT", // 252 (510) - "CURRENCY", // 253 (511) - "CURRENT", // 254 (512) - "CURRENT-DATE", // 255 (513) - "DATA", // 256 (514) - "DATE", // 257 (515) - "DATE-COMPILED", // 258 (516) - "DATE-OF-INTEGER", // 259 (517) - "DATE-TO-YYYYMMDD", // 260 (518) - "DATE-WRITTEN", // 261 (519) - "DAY", // 262 (520) - "DAY-OF-INTEGER", // 263 (521) - "DAY-OF-WEEK", // 264 (522) - "DAY-TO-YYYYDDD", // 265 (523) - "DBCS", // 266 (524) - "DE", // 267 (525) - "DEBUGGING", // 268 (526) - "DECIMAL-POINT", // 269 (527) - "DECLARATIVES", // 270 (528) - "DEFAULT", // 271 (529) - "DELIMITED", // 272 (530) - "DELIMITER", // 273 (531) - "DEPENDING", // 274 (532) - "DESCENDING", // 275 (533) - "DETAIL", // 276 (534) - "DIRECT", // 277 (535) - "DIRECT-ACCESS", // 278 (536) - "DOWN", // 279 (537) - "DUPLICATES", // 280 (538) - "DYNAMIC", // 281 (539) - "E", // 282 (540) - "EBCDIC", // 283 (541) - "EC", // 284 (542) - "EGCS", // 285 (543) - "ENTRY", // 286 (544) - "ENVIRONMENT", // 287 (545) - "EQUAL", // 288 (546) - "EVERY", // 289 (547) - "EXAMINE", // 290 (548) - "EXHIBIT", // 291 (549) - "EXP", // 292 (550) - "EXP10", // 293 (551) - "EXTEND", // 294 (552) - "EXTERNAL", // 295 (553) - "EXCEPTION-FILE", // 296 (554) - "EXCEPTION-FILE-N", // 297 (555) - "EXCEPTION-LOCATION", // 298 (556) - "EXCEPTION-LOCATION-N", // 299 (557) - "EXCEPTION-STATEMENT", // 300 (558) - "EXCEPTION-STATUS", // 301 (559) - "FACTORIAL", // 302 (560) - "FALSE", // 303 (561) - "FD", // 304 (562) - "FILE-CONTROL", // 305 (563) - "FILE", // 306 (564) - "FILE-LIMIT", // 307 (565) - "FINAL", // 308 (566) - "FINALLY", // 309 (567) - "FIND-STRING", // 310 (568) - "FIRST", // 311 (569) - "FIXED", // 312 (570) - "FOOTING", // 313 (571) - "FOR", // 314 (572) - "FORMATTED-CURRENT-DATE", // 315 (573) - "FORMATTED-DATE", // 316 (574) - "FORMATTED-DATETIME", // 317 (575) - "FORMATTED-TIME", // 318 (576) - "FORM-OVERFLOW", // 319 (577) - "FREE", // 320 (578) - "FRACTION-PART", // 321 (579) - "FROM", // 322 (580) - "FUNCTION", // 323 (581) - "GENERATE", // 324 (582) - "GIVING", // 325 (583) - "GLOBAL", // 326 (584) - "GO", // 327 (585) - "GROUP", // 328 (586) - "HEADING", // 329 (587) - "HEX", // 330 (588) - "HEX-OF", // 331 (589) - "HEX-TO-CHAR", // 332 (590) - "HIGH-VALUES", // 333 (591) - "HIGHEST-ALGEBRAIC", // 334 (592) - "HOLD", // 335 (593) - "IBM-360", // 336 (594) - "IN", // 337 (595) - "INCLUDE", // 338 (596) - "INDEX", // 339 (597) - "INDEXED", // 340 (598) - "INDICATE", // 341 (599) - "INITIAL", // 342 (600) - "INITIATE", // 343 (601) - "INPUT", // 344 (602) - "INSTALLATION", // 345 (603) - "INTERFACE", // 346 (604) - "INTEGER", // 347 (605) - "INTEGER-OF-BOOLEAN", // 348 (606) - "INTEGER-OF-DATE", // 349 (607) - "INTEGER-OF-DAY", // 350 (608) - "INTEGER-OF-FORMATTED-DATE", // 351 (609) - "INTEGER-PART", // 352 (610) - "INTO", // 353 (611) - "INTRINSIC", // 354 (612) - "INVOKE", // 355 (613) - "I-O", // 356 (614) - "I-O-CONTROL", // 357 (615) - "IS", // 358 (616) - "ISNT", // 359 (617) - "KANJI", // 360 (618) - "KEY", // 361 (619) - "LABEL", // 362 (620) - "LAST", // 363 (621) - "LEADING", // 364 (622) - "LEFT", // 365 (623) - "LENGTH", // 366 (624) - "LENGTH-OF", // 367 (625) - "LIMIT", // 368 (626) - "LIMITS", // 369 (627) - "LINE", // 370 (628) - "LINES", // 371 (629) - "LINE-COUNTER", // 372 (630) - "LINAGE", // 373 (631) - "LINKAGE", // 374 (632) - "LOCALE", // 375 (633) - "LOCALE-COMPARE", // 376 (634) - "LOCALE-DATE", // 377 (635) - "LOCALE-TIME", // 378 (636) - "LOCALE-TIME-FROM-SECONDS", // 379 (637) - "LOCAL-STORAGE", // 380 (638) - "LOCATION", // 381 (639) - "LOCK", // 382 (640) - "LOCK-ON", // 383 (641) - "LOG", // 384 (642) - "LOG10", // 385 (643) - "LOWER-CASE", // 386 (644) - "LOW-VALUES", // 387 (645) - "LOWEST-ALGEBRAIC", // 388 (646) - "LPAREN", // 389 (647) - "MANUAL", // 390 (648) - "MAXX", // 391 (649) - "MEAN", // 392 (650) - "MEDIAN", // 393 (651) - "MIDRANGE", // 394 (652) - "MINN", // 395 (653) - "MULTIPLE", // 396 (654) - "MOD", // 397 (655) - "MODE", // 398 (656) - "MODULE-NAME", // 399 (657) - "NAMED", // 400 (658) - "NAT", // 401 (659) - "NATIONAL", // 402 (660) - "NATIONAL-EDITED", // 403 (661) - "NATIONAL-OF", // 404 (662) - "NATIVE", // 405 (663) - "NESTED", // 406 (664) - "NEXT", // 407 (665) - "NO", // 408 (666) - "NOTE", // 409 (667) - "NULLS", // 410 (668) - "NULLPTR", // 411 (669) - "NUMERIC", // 412 (670) - "NUMERIC-EDITED", // 413 (671) - "NUMVAL", // 414 (672) - "NUMVAL-C", // 415 (673) - "NUMVAL-F", // 416 (674) - "OCCURS", // 417 (675) - "OF", // 418 (676) - "OFF", // 419 (677) - "OMITTED", // 420 (678) - "ON", // 421 (679) - "ONLY", // 422 (680) - "OPTIONAL", // 423 (681) - "OPTIONS", // 424 (682) - "ORD", // 425 (683) - "ORDER", // 426 (684) - "ORD-MAX", // 427 (685) - "ORD-MIN", // 428 (686) - "ORGANIZATION", // 429 (687) - "OTHER", // 430 (688) - "OTHERWISE", // 431 (689) - "OUTPUT", // 432 (690) - "PACKED-DECIMAL", // 433 (691) - "PADDING", // 434 (692) - "PAGE", // 435 (693) - "PAGE-COUNTER", // 436 (694) - "PF", // 437 (695) - "PH", // 438 (696) - "PI", // 439 (697) - "PIC", // 440 (698) - "PICTURE", // 441 (699) - "PLUS", // 442 (700) - "PRESENT-VALUE", // 443 (701) - "PRINT-SWITCH", // 444 (702) - "PROCEDURE", // 445 (703) - "PROCEDURES", // 446 (704) - "PROCEED", // 447 (705) - "PROCESS", // 448 (706) - "PROGRAM-ID", // 449 (707) - "PROGRAM", // 450 (708) - "PROPERTY", // 451 (709) - "PROTOTYPE", // 452 (710) - "PSEUDOTEXT", // 453 (711) - "QUOTES", // 454 (712) - "RANDOM", // 455 (713) - "RANDOM-SEED", // 456 (714) - "RANGE", // 457 (715) - "RAISE", // 458 (716) - "RAISING", // 459 (717) - "RD", // 460 (718) - "RECORD", // 461 (719) - "RECORDING", // 462 (720) - "RECORDS", // 463 (721) - "RECURSIVE", // 464 (722) - "REDEFINES", // 465 (723) - "REEL", // 466 (724) - "REFERENCE", // 467 (725) - "RELATIVE", // 468 (726) - "REM", // 469 (727) - "REMAINDER", // 470 (728) - "REMARKS", // 471 (729) - "REMOVAL", // 472 (730) - "RENAMES", // 473 (731) - "REPLACE", // 474 (732) - "REPLACING", // 475 (733) - "REPORT", // 476 (734) - "REPORTING", // 477 (735) - "REPORTS", // 478 (736) - "REPOSITORY", // 479 (737) - "RERUN", // 480 (738) - "RESERVE", // 481 (739) - "RESTRICTED", // 482 (740) - "RESUME", // 483 (741) - "REVERSE", // 484 (742) - "REVERSED", // 485 (743) - "REWIND", // 486 (744) - "RF", // 487 (745) - "RH", // 488 (746) - "RIGHT", // 489 (747) - "ROUNDED", // 490 (748) - "RUN", // 491 (749) - "SAME", // 492 (750) - "SCREEN", // 493 (751) - "SD", // 494 (752) - "SECONDS-FROM-FORMATTED-TIME", // 495 (753) - "SECONDS-PAST-MIDNIGHT", // 496 (754) - "SECURITY", // 497 (755) - "SEPARATE", // 498 (756) - "SEQUENCE", // 499 (757) - "SEQUENTIAL", // 500 (758) - "SHARING", // 501 (759) - "SIMPLE-EXIT", // 502 (760) - "SIGN", // 503 (761) - "SIN", // 504 (762) - "SIZE", // 505 (763) - "SMALLEST-ALGEBRAIC", // 506 (764) - "SOURCE", // 507 (765) - "SOURCE-COMPUTER", // 508 (766) - "SPECIAL-NAMES", // 509 (767) - "SQRT", // 510 (768) - "STACK", // 511 (769) - "STANDARD", // 512 (770) - "STANDARD-1", // 513 (771) - "STANDARD-DEVIATION", // 514 (772) - "STANDARD-COMPARE", // 515 (773) - "STATUS", // 516 (774) - "STRONG", // 517 (775) - "SUBSTITUTE", // 518 (776) - "SUM", // 519 (777) - "SYMBOL", // 520 (778) - "SYMBOLIC", // 521 (779) - "SYNCHRONIZED", // 522 (780) - "TALLY", // 523 (781) - "TALLYING", // 524 (782) - "TAN", // 525 (783) - "TERMINATE", // 526 (784) - "TEST", // 527 (785) - "TEST-DATE-YYYYMMDD", // 528 (786) - "TEST-DAY-YYYYDDD", // 529 (787) - "TEST-FORMATTED-DATETIME", // 530 (788) - "TEST-NUMVAL", // 531 (789) - "TEST-NUMVAL-C", // 532 (790) - "TEST-NUMVAL-F", // 533 (791) - "THAN", // 534 (792) - "TIME", // 535 (793) - "TIMES", // 536 (794) - "TO", // 537 (795) - "TOP", // 538 (796) - "TOP-LEVEL", // 539 (797) - "TRACKS", // 540 (798) - "TRACK-AREA", // 541 (799) - "TRAILING", // 542 (800) - "TRANSFORM", // 543 (801) - "TRIM", // 544 (802) - "TRUE", // 545 (803) - "TRY", // 546 (804) - "TURN", // 547 (805) - "TYPE", // 548 (806) - "TYPEDEF", // 549 (807) - "ULENGTH", // 550 (808) - "UNBOUNDED", // 551 (809) - "UNIT", // 552 (810) - "UNITS", // 553 (811) - "UNIT-RECORD", // 554 (812) - "UNTIL", // 555 (813) - "UP", // 556 (814) - "UPON", // 557 (815) - "UPOS", // 558 (816) - "UPPER-CASE", // 559 (817) - "USAGE", // 560 (818) - "USING", // 561 (819) - "USUBSTR", // 562 (820) - "USUPPLEMENTARY", // 563 (821) - "UTILITY", // 564 (822) - "UUID4", // 565 (823) - "UVALID", // 566 (824) - "UWIDTH", // 567 (825) - "VALUE", // 568 (826) - "VARIANCE", // 569 (827) - "VARYING", // 570 (828) - "VOLATILE", // 571 (829) - "WHEN-COMPILED", // 572 (830) - "WITH", // 573 (831) - "WORKING-STORAGE", // 574 (832) - "XML", // 575 (833) - "XMLGENERATE", // 576 (834) - "XMLPARSE", // 577 (835) - "YEAR-TO-YYYY", // 578 (836) - "YYYYDDD", // 579 (837) - "YYYYMMDD", // 580 (838) - "ARITHMETIC", // 581 (839) - "ATTRIBUTE", // 582 (840) - "AUTO", // 583 (841) - "AUTOMATIC", // 584 (842) - "AWAY-FROM-ZERO", // 585 (843) - "BACKGROUND-COLOR", // 586 (844) - "BELL", // 587 (845) - "BINARY-ENCODING", // 588 (846) - "BLINK", // 589 (847) - "CAPACITY", // 590 (848) - "CENTER", // 591 (849) - "CLASSIFICATION", // 592 (850) - "CYCLE", // 593 (851) - "DECIMAL-ENCODING", // 594 (852) - "ENTRY-CONVENTION", // 595 (853) - "EOL", // 596 (854) - "EOS", // 597 (855) - "ERASE", // 598 (856) - "EXPANDS", // 599 (857) - "FLOAT-BINARY", // 600 (858) - "FLOAT-DECIMAL", // 601 (859) - "FOREGROUND-COLOR", // 602 (860) - "FOREVER", // 603 (861) - "FULL", // 604 (862) - "HIGHLIGHT", // 605 (863) - "HIGH-ORDER-LEFT", // 606 (864) - "HIGH-ORDER-RIGHT", // 607 (865) - "IGNORING", // 608 (866) - "IMPLEMENTS", // 609 (867) - "INITIALIZED", // 610 (868) - "INTERMEDIATE", // 611 (869) - "LC-ALL", // 612 (870) - "LC-COLLATE", // 613 (871) - "LC-CTYPE", // 614 (872) - "LC-MESSAGES", // 615 (873) - "LC-MONETARY", // 616 (874) - "LC-NUMERIC", // 617 (875) - "LC-TIME", // 618 (876) - "LOWLIGHT", // 619 (877) - "NEAREST-AWAY-FROM-ZERO", // 620 (878) - "NEAREST-EVEN", // 621 (879) - "NEAREST-TOWARD-ZERO", // 622 (880) - "NONE", // 623 (881) - "NORMAL", // 624 (882) - "NUMBERS", // 625 (883) - "PREFIXED", // 626 (884) - "PREVIOUS", // 627 (885) - "PROHIBITED", // 628 (886) - "RELATION", // 629 (887) - "REQUIRED", // 630 (888) - "REVERSE-VIDEO", // 631 (889) - "ROUNDING", // 632 (890) - "SECONDS", // 633 (891) - "SECURE", // 634 (892) - "SHORT", // 635 (893) - "SIGNED", // 636 (894) - "STANDARD-BINARY", // 637 (895) - "STANDARD-DECIMAL", // 638 (896) - "STATEMENT", // 639 (897) - "STEP", // 640 (898) - "STRUCTURE", // 641 (899) - "TOWARD-GREATER", // 642 (900) - "TOWARD-LESSER", // 643 (901) - "TRUNCATION", // 644 (902) - "UCS-4", // 645 (903) - "UNDERLINE", // 646 (904) - "UNSIGNED", // 647 (905) - "UTF-16", // 648 (906) - "UTF-8", // 649 (907) - "ADDRESS", // 650 (908) - "END-ACCEPT", // 651 (909) - "END-ADD", // 652 (910) - "END-CALL", // 653 (911) - "END-COMPUTE", // 654 (912) - "END-DELETE", // 655 (913) - "END-DISPLAY", // 656 (914) - "END-DIVIDE", // 657 (915) - "END-EVALUATE", // 658 (916) - "END-MULTIPLY", // 659 (917) - "END-PERFORM", // 660 (918) - "END-READ", // 661 (919) - "END-RETURN", // 662 (920) - "END-REWRITE", // 663 (921) - "END-SEARCH", // 664 (922) - "END-START", // 665 (923) - "END-STRING", // 666 (924) - "END-SUBTRACT", // 667 (925) - "END-UNSTRING", // 668 (926) - "END-WRITE", // 669 (927) - "END-IF", // 670 (928) - "THRU", // 671 (929) - "OR", // 672 (930) - "AND", // 673 (931) - "NOT", // 674 (932) - "NE", // 675 (933) - "LE", // 676 (934) - "GE", // 677 (935) - "POW", // 678 (936) - "NEG", // 679 (937) + "IDENTIFICATION", // 0 (258) + "ENVIRONMENT", // 1 (259) + "PROCEDURE", // 2 (260) + "DATA", // 3 (261) + "FILE", // 4 (262) + "INPUT-OUTPUT", // 5 (263) + "LINKAGE", // 6 (264) + "LOCAL-STORAGE", // 7 (265) + "WORKING-STORAGE", // 8 (266) + "OBJECT-COMPUTER", // 9 (267) + "DISPLAY-OF", // 10 (268) + "END-FUNCTION", // 11 (269) + "END-PROGRAM", // 12 (270) + "END-SUBPROGRAM", // 13 (271) + "JUSTIFIED", // 14 (272) + "RETURNING", // 15 (273) + "NO-CONDITION", // 16 (274) + "ALNUM", // 17 (275) + "ALPHED", // 18 (276) + "ERROR", // 19 (277) + "EXCEPTION", // 20 (278) + "SIZE-ERROR", // 21 (279) + "EXCEPTION-NAME", // 22 (280) + "LEVEL", // 23 (281) + "LEVEL66", // 24 (282) + "LEVEL78", // 25 (283) + "LEVEL88", // 26 (284) + "CLASS-NAME", // 27 (285) + "NAME", // 28 (286) + "NAME88", // 29 (287) + "NUME", // 30 (288) + "NUMED", // 31 (289) + "NUMED-CR", // 32 (290) + "NUMED-DB", // 33 (291) + "NINEDOT", // 34 (292) + "NINES", // 35 (293) + "NINEV", // 36 (294) + "PIC-P", // 37 (295) + "ONES", // 38 (296) + "SPACES", // 39 (297) + "LITERAL", // 40 (298) + "END", // 41 (299) + "EOP", // 42 (300) + "FILENAME", // 43 (301) + "INVALID", // 44 (302) + "NUMBER", // 45 (303) + "NEGATIVE", // 46 (304) + "NUMSTR", // 47 (305) + "OVERFLOW", // 48 (306) + "BINARY-INTEGER", // 49 (307) + "COMPUTATIONAL", // 50 (308) + "PERFORM", // 51 (309) + "BACKWARD", // 52 (310) + "POSITIVE", // 53 (311) + "POINTER", // 54 (312) + "SECTION", // 55 (313) + "STANDARD-ALPHABET", // 56 (314) + "SWITCH", // 57 (315) + "UPSI", // 58 (316) + "ZERO", // 59 (317) + "SYSIN", // 60 (318) + "SYSIPT", // 61 (319) + "SYSOUT", // 62 (320) + "SYSLIST", // 63 (321) + "SYSLST", // 64 (322) + "SYSPUNCH", // 65 (323) + "SYSPCH", // 66 (324) + "CONSOLE", // 67 (325) + "C01", // 68 (326) + "C02", // 69 (327) + "C03", // 70 (328) + "C04", // 71 (329) + "C05", // 72 (330) + "C06", // 73 (331) + "C07", // 74 (332) + "C08", // 75 (333) + "C09", // 76 (334) + "C10", // 77 (335) + "C11", // 78 (336) + "C12", // 79 (337) + "CSP", // 80 (338) + "S01", // 81 (339) + "S02", // 82 (340) + "S03", // 83 (341) + "S04", // 84 (342) + "S05", // 85 (343) + "AFP-5A", // 86 (344) + "STDIN", // 87 (345) + "STDOUT", // 88 (346) + "STDERR", // 89 (347) + "LIST", // 90 (348) + "MAP", // 91 (349) + "NOLIST", // 92 (350) + "NOMAP", // 93 (351) + "NOSOURCE", // 94 (352) + "MIGHT-BE", // 95 (353) + "FUNCTION-UDF", // 96 (354) + "FUNCTION-UDF-0", // 97 (355) + "DATE-FMT", // 98 (356) + "TIME-FMT", // 99 (357) + "DATETIME-FMT", // 100 (358) + "BASIS", // 101 (359) + "CBL", // 102 (360) + "CONSTANT", // 103 (361) + "COPY", // 104 (362) + "DEFINED", // 105 (363) + "ENTER", // 106 (364) + "FEATURE", // 107 (365) + "INSERTT", // 108 (366) + "LSUB", // 109 (367) + "PARAMETER", // 110 (368) + "OVERRIDE", // 111 (369) + "READY", // 112 (370) + "RESET", // 113 (371) + "RSUB", // 114 (372) + "SERVICE-RELOAD", // 115 (373) + "STAR-CBL", // 116 (374) + "SUBSCRIPT", // 117 (375) + "SUPPRESS", // 118 (376) + "TITLE", // 119 (377) + "TRACE", // 120 (378) + "USE", // 121 (379) + "COBOL-WORDS", // 122 (380) + "EQUATE", // 123 (381) + "UNDEFINE", // 124 (382) + "CDF-DEFINE", // 125 (383) + "CDF-DISPLAY", // 126 (384) + "CDF-IF", // 127 (385) + "CDF-ELSE", // 128 (386) + "CDF-END-IF", // 129 (387) + "CDF-EVALUATE", // 130 (388) + "CDF-WHEN", // 131 (389) + "CDF-END-EVALUATE", // 132 (390) + "CALL-COBOL", // 133 (391) + "CALL-VERBATIM", // 134 (392) + "IF", // 135 (393) + "THEN", // 136 (394) + "ELSE", // 137 (395) + "SENTENCE", // 138 (396) + "ACCEPT", // 139 (397) + "ADD", // 140 (398) + "ALTER", // 141 (399) + "CALL", // 142 (400) + "CANCEL", // 143 (401) + "CLOSE", // 144 (402) + "COMPUTE", // 145 (403) + "CONTINUE", // 146 (404) + "DELETE", // 147 (405) + "DISPLAY", // 148 (406) + "DIVIDE", // 149 (407) + "EVALUATE", // 150 (408) + "EXIT", // 151 (409) + "FILLER", // 152 (410) + "GOBACK", // 153 (411) + "GOTO", // 154 (412) + "INITIALIZE", // 155 (413) + "INSPECT", // 156 (414) + "MERGE", // 157 (415) + "MOVE", // 158 (416) + "MULTIPLY", // 159 (417) + "OPEN", // 160 (418) + "PARAGRAPH", // 161 (419) + "READ", // 162 (420) + "RELEASE", // 163 (421) + "RETURN", // 164 (422) + "REWRITE", // 165 (423) + "SEARCH", // 166 (424) + "SET", // 167 (425) + "SELECT", // 168 (426) + "SORT", // 169 (427) + "SORT-MERGE", // 170 (428) + "STRING", // 171 (429) + "STOP", // 172 (430) + "SUBTRACT", // 173 (431) + "START", // 174 (432) + "UNSTRING", // 175 (433) + "WRITE", // 176 (434) + "WHEN", // 177 (435) + "ABS", // 178 (436) + "ACCESS", // 179 (437) + "ACOS", // 180 (438) + "ACTUAL", // 181 (439) + "ADVANCING", // 182 (440) + "AFTER", // 183 (441) + "ALL", // 184 (442) + "ALLOCATE", // 185 (443) + "ALPHABET", // 186 (444) + "ALPHABETIC", // 187 (445) + "ALPHABETIC-LOWER", // 188 (446) + "ALPHABETIC-UPPER", // 189 (447) + "ALPHANUMERIC", // 190 (448) + "ALPHANUMERIC-EDITED", // 191 (449) + "ALSO", // 192 (450) + "ALTERNATE", // 193 (451) + "ANNUITY", // 194 (452) + "ANUM", // 195 (453) + "ANY", // 196 (454) + "ANYCASE", // 197 (455) + "APPLY", // 198 (456) + "ARE", // 199 (457) + "AREA", // 200 (458) + "AREAS", // 201 (459) + "AS", // 202 (460) + "ASCENDING", // 203 (461) + "ACTIVATING", // 204 (462) + "ASIN", // 205 (463) + "ASSIGN", // 206 (464) + "AT", // 207 (465) + "ATAN", // 208 (466) + "BASED", // 209 (467) + "BASECONVERT", // 210 (468) + "BEFORE", // 211 (469) + "BINARY", // 212 (470) + "BIT", // 213 (471) + "BIT-OF", // 214 (472) + "BIT-TO-CHAR", // 215 (473) + "BLANK", // 216 (474) + "BLOCK", // 217 (475) + "BOOLEAN-OF-INTEGER", // 218 (476) + "BOTTOM", // 219 (477) + "BY", // 220 (478) + "BYTE", // 221 (479) + "BYTE-LENGTH", // 222 (480) + "CF", // 223 (481) + "CH", // 224 (482) + "CHANGED", // 225 (483) + "CHAR", // 226 (484) + "CHAR-NATIONAL", // 227 (485) + "CHARACTER", // 228 (486) + "CHARACTERS", // 229 (487) + "CHECKING", // 230 (488) + "CLASS", // 231 (489) + "COBOL", // 232 (490) + "CODE", // 233 (491) + "CODE-SET", // 234 (492) + "COLLATING", // 235 (493) + "COLUMN", // 236 (494) + "COMBINED-DATETIME", // 237 (495) + "COMMA", // 238 (496) + "COMMAND-LINE", // 239 (497) + "COMMAND-LINE-COUNT", // 240 (498) + "COMMIT", // 241 (499) + "COMMON", // 242 (500) + "CONCAT", // 243 (501) + "CONDITION", // 244 (502) + "CONFIGURATION", // 245 (503) + "CONTAINS", // 246 (504) + "CONTENT", // 247 (505) + "CONTROL", // 248 (506) + "CONTROLS", // 249 (507) + "CONVERT", // 250 (508) + "CONVERTING", // 251 (509) + "CORRESPONDING", // 252 (510) + "COS", // 253 (511) + "COUNT", // 254 (512) + "CURRENCY", // 255 (513) + "CURRENT", // 256 (514) + "CURRENT-DATE", // 257 (515) + "DATA", // 258 (516) + "DATE", // 259 (517) + "DATE-COMPILED", // 260 (518) + "DATE-OF-INTEGER", // 261 (519) + "DATE-TO-YYYYMMDD", // 262 (520) + "DATE-WRITTEN", // 263 (521) + "DAY", // 264 (522) + "DAY-OF-INTEGER", // 265 (523) + "DAY-OF-WEEK", // 266 (524) + "DAY-TO-YYYYDDD", // 267 (525) + "DBCS", // 268 (526) + "DE", // 269 (527) + "DEBUGGING", // 270 (528) + "DECIMAL-POINT", // 271 (529) + "DECLARATIVES", // 272 (530) + "DEFAULT", // 273 (531) + "DELIMITED", // 274 (532) + "DELIMITER", // 275 (533) + "DEPENDING", // 276 (534) + "DESCENDING", // 277 (535) + "DETAIL", // 278 (536) + "DIRECT", // 279 (537) + "DIRECT-ACCESS", // 280 (538) + "DOWN", // 281 (539) + "DUPLICATES", // 282 (540) + "DYNAMIC", // 283 (541) + "E", // 284 (542) + "EBCDIC", // 285 (543) + "EC", // 286 (544) + "EGCS", // 287 (545) + "ENTRY", // 288 (546) + "ENVIRONMENT", // 289 (547) + "EQUAL", // 290 (548) + "EVERY", // 291 (549) + "EXAMINE", // 292 (550) + "EXHIBIT", // 293 (551) + "EXP", // 294 (552) + "EXP10", // 295 (553) + "EXTEND", // 296 (554) + "EXTERNAL", // 297 (555) + "EXCEPTION-FILE", // 298 (556) + "EXCEPTION-FILE-N", // 299 (557) + "EXCEPTION-LOCATION", // 300 (558) + "EXCEPTION-LOCATION-N", // 301 (559) + "EXCEPTION-STATEMENT", // 302 (560) + "EXCEPTION-STATUS", // 303 (561) + "FACTORIAL", // 304 (562) + "FALSE", // 305 (563) + "FD", // 306 (564) + "FILE-CONTROL", // 307 (565) + "FILE", // 308 (566) + "FILE-LIMIT", // 309 (567) + "FINAL", // 310 (568) + "FINALLY", // 311 (569) + "FIND-STRING", // 312 (570) + "FIRST", // 313 (571) + "FIXED", // 314 (572) + "FOOTING", // 315 (573) + "FOR", // 316 (574) + "FORMATTED-CURRENT-DATE", // 317 (575) + "FORMATTED-DATE", // 318 (576) + "FORMATTED-DATETIME", // 319 (577) + "FORMATTED-TIME", // 320 (578) + "FORM-OVERFLOW", // 321 (579) + "FREE", // 322 (580) + "FRACTION-PART", // 323 (581) + "FROM", // 324 (582) + "FUNCTION", // 325 (583) + "GENERATE", // 326 (584) + "GIVING", // 327 (585) + "GLOBAL", // 328 (586) + "GO", // 329 (587) + "GROUP", // 330 (588) + "HEADING", // 331 (589) + "HEX", // 332 (590) + "HEX-OF", // 333 (591) + "HEX-TO-CHAR", // 334 (592) + "HIGH-VALUES", // 335 (593) + "HIGHEST-ALGEBRAIC", // 336 (594) + "HOLD", // 337 (595) + "IBM-360", // 338 (596) + "IN", // 339 (597) + "INCLUDE", // 340 (598) + "INDEX", // 341 (599) + "INDEXED", // 342 (600) + "INDICATE", // 343 (601) + "INITIAL", // 344 (602) + "INITIATE", // 345 (603) + "INPUT", // 346 (604) + "INSTALLATION", // 347 (605) + "INTERFACE", // 348 (606) + "INTEGER", // 349 (607) + "INTEGER-OF-BOOLEAN", // 350 (608) + "INTEGER-OF-DATE", // 351 (609) + "INTEGER-OF-DAY", // 352 (610) + "INTEGER-OF-FORMATTED-DATE", // 353 (611) + "INTEGER-PART", // 354 (612) + "INTO", // 355 (613) + "INTRINSIC", // 356 (614) + "INVOKE", // 357 (615) + "I-O", // 358 (616) + "I-O-CONTROL", // 359 (617) + "IS", // 360 (618) + "ISNT", // 361 (619) + "KANJI", // 362 (620) + "KEY", // 363 (621) + "LABEL", // 364 (622) + "LAST", // 365 (623) + "LEADING", // 366 (624) + "LEFT", // 367 (625) + "LENGTH", // 368 (626) + "LENGTH-OF", // 369 (627) + "LIMIT", // 370 (628) + "LIMITS", // 371 (629) + "LINE", // 372 (630) + "LINES", // 373 (631) + "LINE-COUNTER", // 374 (632) + "LINAGE", // 375 (633) + "LINKAGE", // 376 (634) + "LOCALE", // 377 (635) + "LOCALE-COMPARE", // 378 (636) + "LOCALE-DATE", // 379 (637) + "LOCALE-TIME", // 380 (638) + "LOCALE-TIME-FROM-SECONDS", // 381 (639) + "LOCAL-STORAGE", // 382 (640) + "LOCATION", // 383 (641) + "LOCK", // 384 (642) + "LOCK-ON", // 385 (643) + "LOG", // 386 (644) + "LOG10", // 387 (645) + "LOWER-CASE", // 388 (646) + "LOW-VALUES", // 389 (647) + "LOWEST-ALGEBRAIC", // 390 (648) + "LPAREN", // 391 (649) + "MANUAL", // 392 (650) + "MAXX", // 393 (651) + "MEAN", // 394 (652) + "MEDIAN", // 395 (653) + "MIDRANGE", // 396 (654) + "MINN", // 397 (655) + "MULTIPLE", // 398 (656) + "MOD", // 399 (657) + "MODE", // 400 (658) + "MODULE-NAME", // 401 (659) + "NAMED", // 402 (660) + "NAT", // 403 (661) + "NATIONAL", // 404 (662) + "NATIONAL-EDITED", // 405 (663) + "NATIONAL-OF", // 406 (664) + "NATIVE", // 407 (665) + "NESTED", // 408 (666) + "NEXT", // 409 (667) + "NO", // 410 (668) + "NOTE", // 411 (669) + "NULLS", // 412 (670) + "NULLPTR", // 413 (671) + "NUMERIC", // 414 (672) + "NUMERIC-EDITED", // 415 (673) + "NUMVAL", // 416 (674) + "NUMVAL-C", // 417 (675) + "NUMVAL-F", // 418 (676) + "OCCURS", // 419 (677) + "OF", // 420 (678) + "OFF", // 421 (679) + "OMITTED", // 422 (680) + "ON", // 423 (681) + "ONLY", // 424 (682) + "OPTIONAL", // 425 (683) + "OPTIONS", // 426 (684) + "ORD", // 427 (685) + "ORDER", // 428 (686) + "ORD-MAX", // 429 (687) + "ORD-MIN", // 430 (688) + "ORGANIZATION", // 431 (689) + "OTHER", // 432 (690) + "OTHERWISE", // 433 (691) + "OUTPUT", // 434 (692) + "PACKED-DECIMAL", // 435 (693) + "PADDING", // 436 (694) + "PAGE", // 437 (695) + "PAGE-COUNTER", // 438 (696) + "PF", // 439 (697) + "PH", // 440 (698) + "PI", // 441 (699) + "PIC", // 442 (700) + "PICTURE", // 443 (701) + "PLUS", // 444 (702) + "PRESENT-VALUE", // 445 (703) + "PRINT-SWITCH", // 446 (704) + "PROCEDURE", // 447 (705) + "PROCEDURES", // 448 (706) + "PROCEED", // 449 (707) + "PROCESS", // 450 (708) + "PROGRAM-ID", // 451 (709) + "PROGRAM", // 452 (710) + "PROPERTY", // 453 (711) + "PROTOTYPE", // 454 (712) + "PSEUDOTEXT", // 455 (713) + "QUOTES", // 456 (714) + "RANDOM", // 457 (715) + "RANDOM-SEED", // 458 (716) + "RANGE", // 459 (717) + "RAISE", // 460 (718) + "RAISING", // 461 (719) + "RD", // 462 (720) + "RECORD", // 463 (721) + "RECORDING", // 464 (722) + "RECORDS", // 465 (723) + "RECURSIVE", // 466 (724) + "REDEFINES", // 467 (725) + "REEL", // 468 (726) + "REFERENCE", // 469 (727) + "RELATIVE", // 470 (728) + "REM", // 471 (729) + "REMAINDER", // 472 (730) + "REMARKS", // 473 (731) + "REMOVAL", // 474 (732) + "RENAMES", // 475 (733) + "REPLACE", // 476 (734) + "REPLACING", // 477 (735) + "REPORT", // 478 (736) + "REPORTING", // 479 (737) + "REPORTS", // 480 (738) + "REPOSITORY", // 481 (739) + "RERUN", // 482 (740) + "RESERVE", // 483 (741) + "RESTRICTED", // 484 (742) + "RESUME", // 485 (743) + "REVERSE", // 486 (744) + "REVERSED", // 487 (745) + "REWIND", // 488 (746) + "RF", // 489 (747) + "RH", // 490 (748) + "RIGHT", // 491 (749) + "ROUNDED", // 492 (750) + "RUN", // 493 (751) + "SAME", // 494 (752) + "SCREEN", // 495 (753) + "SD", // 496 (754) + "SECONDS-FROM-FORMATTED-TIME", // 497 (755) + "SECONDS-PAST-MIDNIGHT", // 498 (756) + "SECURITY", // 499 (757) + "SEPARATE", // 500 (758) + "SEQUENCE", // 501 (759) + "SEQUENTIAL", // 502 (760) + "SHARING", // 503 (761) + "SIMPLE-EXIT", // 504 (762) + "SIGN", // 505 (763) + "SIN", // 506 (764) + "SIZE", // 507 (765) + "SMALLEST-ALGEBRAIC", // 508 (766) + "SOURCE", // 509 (767) + "SOURCE-COMPUTER", // 510 (768) + "SPECIAL-NAMES", // 511 (769) + "SQRT", // 512 (770) + "STACK", // 513 (771) + "STANDARD", // 514 (772) + "STANDARD-1", // 515 (773) + "STANDARD-DEVIATION", // 516 (774) + "STANDARD-COMPARE", // 517 (775) + "STATUS", // 518 (776) + "STRONG", // 519 (777) + "SUBSTITUTE", // 520 (778) + "SUM", // 521 (779) + "SYMBOL", // 522 (780) + "SYMBOLIC", // 523 (781) + "SYNCHRONIZED", // 524 (782) + "TALLY", // 525 (783) + "TALLYING", // 526 (784) + "TAN", // 527 (785) + "TERMINATE", // 528 (786) + "TEST", // 529 (787) + "TEST-DATE-YYYYMMDD", // 530 (788) + "TEST-DAY-YYYYDDD", // 531 (789) + "TEST-FORMATTED-DATETIME", // 532 (790) + "TEST-NUMVAL", // 533 (791) + "TEST-NUMVAL-C", // 534 (792) + "TEST-NUMVAL-F", // 535 (793) + "THAN", // 536 (794) + "TIME", // 537 (795) + "TIMES", // 538 (796) + "TO", // 539 (797) + "TOP", // 540 (798) + "TOP-LEVEL", // 541 (799) + "TRACKS", // 542 (800) + "TRACK-AREA", // 543 (801) + "TRAILING", // 544 (802) + "TRANSFORM", // 545 (803) + "TRIM", // 546 (804) + "TRUE", // 547 (805) + "TRY", // 548 (806) + "TURN", // 549 (807) + "TYPE", // 550 (808) + "TYPEDEF", // 551 (809) + "ULENGTH", // 552 (810) + "UNBOUNDED", // 553 (811) + "UNIT", // 554 (812) + "UNITS", // 555 (813) + "UNIT-RECORD", // 556 (814) + "UNTIL", // 557 (815) + "UP", // 558 (816) + "UPON", // 559 (817) + "UPOS", // 560 (818) + "UPPER-CASE", // 561 (819) + "USAGE", // 562 (820) + "USING", // 563 (821) + "USUBSTR", // 564 (822) + "USUPPLEMENTARY", // 565 (823) + "UTILITY", // 566 (824) + "UUID4", // 567 (825) + "UVALID", // 568 (826) + "UWIDTH", // 569 (827) + "VALUE", // 570 (828) + "VARIANCE", // 571 (829) + "VARYING", // 572 (830) + "VOLATILE", // 573 (831) + "WHEN-COMPILED", // 574 (832) + "WITH", // 575 (833) + "WORKING-STORAGE", // 576 (834) + "XML", // 577 (835) + "XMLGENERATE", // 578 (836) + "XMLPARSE", // 579 (837) + "YEAR-TO-YYYY", // 580 (838) + "YYYYDDD", // 581 (839) + "YYYYMMDD", // 582 (840) + "ARITHMETIC", // 583 (841) + "ATTRIBUTE", // 584 (842) + "AUTO", // 585 (843) + "AUTOMATIC", // 586 (844) + "AWAY-FROM-ZERO", // 587 (845) + "BACKGROUND-COLOR", // 588 (846) + "BELL", // 589 (847) + "BINARY-ENCODING", // 590 (848) + "BLINK", // 591 (849) + "CAPACITY", // 592 (850) + "CENTER", // 593 (851) + "CLASSIFICATION", // 594 (852) + "CYCLE", // 595 (853) + "DECIMAL-ENCODING", // 596 (854) + "ENTRY-CONVENTION", // 597 (855) + "EOL", // 598 (856) + "EOS", // 599 (857) + "ERASE", // 600 (858) + "EXPANDS", // 601 (859) + "FLOAT-BINARY", // 602 (860) + "FLOAT-DECIMAL", // 603 (861) + "FOREGROUND-COLOR", // 604 (862) + "FOREVER", // 605 (863) + "FULL", // 606 (864) + "HIGHLIGHT", // 607 (865) + "HIGH-ORDER-LEFT", // 608 (866) + "HIGH-ORDER-RIGHT", // 609 (867) + "IGNORING", // 610 (868) + "IMPLEMENTS", // 611 (869) + "INITIALIZED", // 612 (870) + "INTERMEDIATE", // 613 (871) + "LC-ALL", // 614 (872) + "LC-COLLATE", // 615 (873) + "LC-CTYPE", // 616 (874) + "LC-MESSAGES", // 617 (875) + "LC-MONETARY", // 618 (876) + "LC-NUMERIC", // 619 (877) + "LC-TIME", // 620 (878) + "LOWLIGHT", // 621 (879) + "NEAREST-AWAY-FROM-ZERO", // 622 (880) + "NEAREST-EVEN", // 623 (881) + "NEAREST-TOWARD-ZERO", // 624 (882) + "NONE", // 625 (883) + "NORMAL", // 626 (884) + "NUMBERS", // 627 (885) + "PREFIXED", // 628 (886) + "PREVIOUS", // 629 (887) + "PROHIBITED", // 630 (888) + "RELATION", // 631 (889) + "REQUIRED", // 632 (890) + "REVERSE-VIDEO", // 633 (891) + "ROUNDING", // 634 (892) + "SECONDS", // 635 (893) + "SECURE", // 636 (894) + "SHORT", // 637 (895) + "SIGNED", // 638 (896) + "STANDARD-BINARY", // 639 (897) + "STANDARD-DECIMAL", // 640 (898) + "STATEMENT", // 641 (899) + "STEP", // 642 (900) + "STRUCTURE", // 643 (901) + "TOWARD-GREATER", // 644 (902) + "TOWARD-LESSER", // 645 (903) + "TRUNCATION", // 646 (904) + "UCS-4", // 647 (905) + "UNDERLINE", // 648 (906) + "UNSIGNED", // 649 (907) + "UTF-16", // 650 (908) + "UTF-8", // 651 (909) + "ADDRESS", // 652 (910) + "END-ACCEPT", // 653 (911) + "END-ADD", // 654 (912) + "END-CALL", // 655 (913) + "END-COMPUTE", // 656 (914) + "END-DELETE", // 657 (915) + "END-DISPLAY", // 658 (916) + "END-DIVIDE", // 659 (917) + "END-EVALUATE", // 660 (918) + "END-MULTIPLY", // 661 (919) + "END-PERFORM", // 662 (920) + "END-READ", // 663 (921) + "END-RETURN", // 664 (922) + "END-REWRITE", // 665 (923) + "END-SEARCH", // 666 (924) + "END-START", // 667 (925) + "END-STRING", // 668 (926) + "END-SUBTRACT", // 669 (927) + "END-UNSTRING", // 670 (928) + "END-WRITE", // 671 (929) + "END-IF", // 672 (930) + "THRU", // 673 (931) + "OR", // 674 (932) + "AND", // 675 (933) + "NOT", // 676 (934) + "NE", // 677 (935) + "LE", // 678 (936) + "GE", // 679 (937) + "POW", // 680 (938) + "NEG", // 681 (939) }; diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc index 1c0810b..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 "???"; } @@ -324,8 +339,9 @@ is_numeric_edited( const char picture[] ) { break; default: numed_message = xasprintf("invalid PICTURE character " - "'%c' at offset %zu in '%s'", - *p, p - picture, picture); + "'%c' at offset " HOST_SIZE_T_PRINT_UNSIGNED + " in '%s'", + *p, (fmt_size_t)(p - picture), picture); break; } @@ -349,49 +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; - if( 1 != sscanf(p, "%zu", &len) ) { - dbgmsg("%s:%d: no number found in '%s'", __func__, __LINE__, p); - goto irregular; - } - 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); @@ -462,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; } @@ -774,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; @@ -822,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", @@ -885,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); } } } @@ -944,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(); @@ -963,29 +979,28 @@ literal_subscript_oob( const cbl_refer_t& r, size_t& isub /* output */) { * for the corresponding dimension. Return the first subscript not * meeting those criteria, if any. */ - auto p = std::find_if( r.subscripts, esub, - [&pdim]( const cbl_refer_t& r ) { + auto psub = std::find_if( r.subscripts.begin(), r.subscripts.end(), + [pdim]( const cbl_refer_t& r ) mutable { const auto& occurs((*pdim)->occurs); pdim++; return ! occurs.subscript_ok(r.field); } ); - isub = p - r.subscripts; - return p == esub? NULL : dims[isub]; + isub = psub - r.subscripts.begin(); + return psub == r.subscripts.end()? NULL : dims[isub]; } size_t cbl_refer_t::subscripts_set( const std::list<cbl_refer_t>& subs ) { - nsubscript = subs.size(); - subscripts = new cbl_refer_t[nsubscript]; - std::copy( subs.begin(), subs.end(), subscripts ); - + subscripts.clear(); + std::copy( subs.begin(), subs.end(), std::back_inserter(subscripts) ); return dimensions(field); } const char * cbl_refer_t::str() const { static char subscripts[64]; - sprintf(subscripts, "(%u of %zu dimensions)", nsubscript, dimensions(field)); + sprintf(subscripts, "(%u of " HOST_SIZE_T_PRINT_UNSIGNED " dimensions)", + nsubscript(), (fmt_size_t)dimensions(field)); char *output = xasprintf("%s %s %s", field? field_str(field) : "(none)", 0 < dimensions(field)? subscripts : "", @@ -1001,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()); @@ -1031,10 +1046,10 @@ struct move_corresponding_field { tgt.field = cbl_field_of(symbol_at(elem.second)); if( yydebug ) { - dbgmsg("move_corresponding:%d: SRC: %3zu %s", __LINE__, - elem.first, src.str()); - dbgmsg("move_corresponding:%d: to %3zu %s", __LINE__, - elem.second, tgt.str()); + dbgmsg("move_corresponding:%d: SRC: %3" GCC_PRISZ "u %s", __LINE__, + (fmt_size_t)elem.first, src.str()); + dbgmsg("move_corresponding:%d: to %3" GCC_PRISZ "u %s", __LINE__, + (fmt_size_t)elem.second, tgt.str()); } parser_move(tgt, src); @@ -1089,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: @@ -1104,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; } @@ -1138,8 +1151,9 @@ valid_move( const struct cbl_field_t *tgt, const struct cbl_field_t *src ) if( yydebug && ! retval ) { auto bad = std::find_if( p, pend, []( char ch ) { return ! ISDIGIT(ch); } ); - dbgmsg("%s:%d: offending character '%c' at position %zu", - __func__, __LINE__, *bad, bad - p); + dbgmsg("%s:%d: offending character '%c' at position " + HOST_SIZE_T_PRINT_UNSIGNED, + __func__, __LINE__, *bad, (fmt_size_t)(bad - p)); } } break; @@ -1172,12 +1186,6 @@ valid_move( const struct cbl_field_t *tgt, const struct cbl_field_t *src ) } } - if( yydebug && getenv(__func__) ) { - dbgmsg("%s:%d: ok to move %s to %s (0x%02x)", __func__, __LINE__, - cbl_field_type_str(src->type), cbl_field_type_str(tgt->type), - retval); - } - return retval; } @@ -1369,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) {} @@ -1378,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)); } @@ -1415,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; @@ -1443,16 +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()); - if( getenv(__func__) ) { - dbgmsg("%s: %zu for ref %s of '%s' (line %d) " - "in %s of '%s' (as %s of '%s')", __func__, - procedures.count(full_ref), - ref.paragraph(), ref.section(), ref.line_number(), - key.paragraph(), key.section(), - full_ref.paragraph(), full_ref.section() ); - } - - 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. @@ -1473,9 +1465,6 @@ procedure_definition_add( size_t program, const cbl_label_t *procedure ) { } procdef_t key( section_name, paragraph_name, isym ); - if( getenv(__func__) ) { - dbgmsg("%s: #%3zu %s of %s", __func__, isym, paragraph_name, section_name); - } current_procedure = programs[program].insert( make_pair(key, procedures_t::mapped_type()) ); } @@ -1485,9 +1474,6 @@ void procedure_reference_add( const char *section, const char *paragraph, int line, size_t context ) { - if( getenv(__func__) ) { - dbgmsg("%s: line %3d %s of %s", __func__, line, paragraph, section); - } current_procedure->second.push_back( procref_t(section, paragraph, line, context) ); } @@ -1518,10 +1504,11 @@ ambiguous_reference( size_t program ) { ambiguous = find_if_not( proc.second.begin(), proc.second.end(), is_unique(program, proc.first) ); if( proc.second.end() != ambiguous ) { - if( yydebug || getenv("symbol_label_add")) { - dbgmsg("%s: %s of '%s' has %zu potential matches", __func__, - ambiguous->paragraph(), ambiguous->section(), - procedures.count(*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(procdef_t(*ambiguous))); } return new procref_t(*ambiguous); } @@ -1548,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 ) { @@ -1564,9 +1551,9 @@ parent_names( const symbol_elem_t *elem, if( is_filler(cbl_field_of(elem)) ) return; - // dbgmsg("%s: asked about %s of %s (%zu away)", __func__, + // dbgmsg("%s: asked about %s of %s (" HOST_SIZE_T_PRINT_UNSIGNED " away)", __func__, // cbl_field_of(elem)->name, - // cbl_field_of(group)->name, elem - group); + // cbl_field_of(group)->name, (fmt_size_t)(elem - group)); for( const symbol_elem_t *e=elem; e && group < e; e = symbol_parent(e) ) { names.push_front( cbl_field_of(e)->name ); @@ -1585,15 +1572,17 @@ public: symbol_elem_t *rgroup, type_t type ) : lgroup(lgroup), rgroup(rgroup), type(type) { - dbgmsg( "%s:%d: for #%zu %s and #%zu %s on line %d", __func__, __LINE__, - symbol_index(lgroup), cbl_field_of(lgroup)->name, - symbol_index(rgroup), cbl_field_of(rgroup)->name, yylineno ); + dbgmsg( "%s:%d: for #" HOST_SIZE_T_PRINT_UNSIGNED + " %s and #" HOST_SIZE_T_PRINT_UNSIGNED " %s on line %d", + __func__, __LINE__, + (fmt_size_t)symbol_index(lgroup), cbl_field_of(lgroup)->name, + (fmt_size_t)symbol_index(rgroup), cbl_field_of(rgroup)->name, yylineno ); } 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; } @@ -1664,8 +1653,9 @@ corresponding_fields( cbl_field_t *lhs, cbl_field_t *rhs, lhsg.a = symbols_begin(field_index(lhs)); lhsg.z = std::find_if( lhsg.a, symbols_end(), next_group(lhsg.a) ); - dbgmsg("%s:%d: examining %zu symbols after %s", __func__, __LINE__, - lhsg.z - lhsg.a, lhs->name); + dbgmsg("%s:%d: examining " HOST_SIZE_T_PRINT_UNSIGNED " symbols after %s", + __func__, __LINE__, + (fmt_size_t)(lhsg.z - lhsg.a), lhs->name); find_corresponding finder( symbol_at(field_index(lhs)), symbol_at(field_index(rhs)), type ); @@ -1673,8 +1663,9 @@ corresponding_fields( cbl_field_t *lhs, cbl_field_t *rhs, output.erase(0); - dbgmsg( "%s:%d: %s and %s have %zu corresponding fields", - __func__, __LINE__, lhs->name, rhs->name, output.size() ); + dbgmsg( "%s:%d: %s and %s have " HOST_SIZE_T_PRINT_UNSIGNED + " corresponding fields", + __func__, __LINE__, lhs->name, rhs->name, (fmt_size_t)output.size() ); return output; } @@ -1752,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(); } @@ -1775,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(); @@ -1793,21 +1798,39 @@ class unique_stack : public std::stack<input_file_t> "----- ---- --------" "----------------------------------------"); for( const auto& v : c ) { - dbgmsg( " %4zu %4d %s", c.size() - --n, v.lineno, no_wd(wd, v.name) ); + dbgmsg( " %4" GCC_PRISZ "u %4d %s", + (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"); } }; @@ -1816,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 @@ -1826,12 +1855,13 @@ 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() ) { for( auto& elem : old_filenames ) { - dbgmsg("%6zu %-30s", elem.second, elem.first.c_str()); + dbgmsg("%6" GCC_PRISZ "u %-30s", + (fmt_size_t)elem.second, elem.first.c_str()); } cbl_errx( "logic error: missing inode for %s", name); } @@ -1840,32 +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; - if( getenv(__func__) ) { - dbgmsg(" saving %s with lineno as %d", - input_filenames.top().name, input_filenames.top().lineno); - } + 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; - if( getenv(__func__) ) { - dbgmsg(" setting %s with lineno as %d", input.name, input.lineno); - } + 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() ); @@ -1873,21 +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; - if( getenv("cobol_filename") ) { - dbgmsg("restoring %s with lineno to %d", input.name, 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 ) { @@ -1915,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); @@ -1938,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); @@ -1960,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) { @@ -1968,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 }; @@ -2014,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); @@ -2081,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; @@ -2094,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; } @@ -2102,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 @@ -2114,40 +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( getenv(__func__) ) return filename; // ignore #line directive - 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; } -class timespec_t { - struct timespec now; +//#define TIMING_PARSE +#ifdef TIMING_PARSE +class cbl_timespec { + uint64_t now; // Nanoseconds public: - timespec_t() { - clock_gettime(CLOCK_MONOTONIC, &now); + cbl_timespec() { + now = get_time_nanoseconds(); } double ns() const { - return now.tv_sec * 1000000000 + now.tv_nsec; + return now; } - friend double operator-( const timespec_t& now, const timespec_t& then ); + friend double operator-( const cbl_timespec& now, const cbl_timespec& then ); }; double -operator-( const timespec_t& then, const timespec_t& now ) { +operator-( const cbl_timespec& now, const cbl_timespec& then ) { return (now.ns() - then.ns()) / 1000000000; } +#endif static int parse_file( const char filename[] ) @@ -2158,15 +2186,25 @@ parse_file( const char filename[] ) parser_enter_file(filename); - timespec_t start; + if( input_filenames.option() == 'M' ) { + input_filenames.print(); + return 0; + } + +#ifdef TIMING_PARSE + cbl_timespec start; +#endif int erc = yyparse(); - timespec_t finish; +#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); @@ -2190,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; } @@ -2235,6 +2263,7 @@ cbl_message(int fd, const char *format_string, ...) char *ostring = xvasprintf(format_string, ap); va_end(ap); write(fd, ostring, strlen(ostring)); + write(fd, "\n", 1); free(ostring); } @@ -2324,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); } @@ -2335,12 +2364,621 @@ bool fisdigit(int c) bool fisspace(int c) { return ISSPACE(c); - }; + } int ftolower(int c) { return TOLOWER(c); } +int ftoupper(int c) + { + return TOUPPER(c); + } bool fisprint(int c) { return ISPRINT(c); - }; + } + +// 8.9 Reserved words +static const std::set<std::string> reserved_words = { + // GCC COBOL keywords + "COMMAND-LINE", + "COMMAND-LINE-COUNT", + + // GCC device names + "C01", + "C02", + "C03", + "C04", + "C05", + "C06", + "C07", + "C08", + "C09", + "C10", + "C11", + "C12", + "CONSOLE", + "S01", + "S02", + "S03", + "S04", + "S05", + "STDERR", + "STDIN", + "STDOUT", + "SYSIN", + "SYSIPT", + "SYSLIST", + "SYSLST", + "SYSOUT", + "SYSPCH", + "SYSPUNCH", + "UPSI", + + // IBM keywords that GCC recognizes + "BASIS", + "CBL", + "ENTER", + "READY", + "TITLE", + "TRACE", + "ALTER", + "COBOL", + "DATE-COMPILED", + "DATE-WRITTEN", + "DBCS", + "DEBUGGING", + "EGCS", + "ENTRY", + "EVERY", + "INSTALLATION", + "I-O-CONTROL", + "KANJI", + "LABEL", + "NULLS", + "PADDING", + "PROCEDURES", + "PROCEED", + "RECORDING", + "RERUN", + "REVERSED", + "SECURITY", + "TALLY", + "VOLATILE", + "XML", + "END-START", + + // ISO 2023 keywords + "ACCEPT", + "ACCESS", + "ACTIVE-CLASS", + "ADD", + "ADDRESS", + "ADVANCING", + "AFTER", + "ALIGNED", + "ALL", + "ALLOCATE", + "ALPHABET", + "ALPHABETIC", + "ALPHABETIC-LOWER", + "ALPHABETIC-UPPER", + "ALPHANUMERIC", + "ALPHANUMERIC-EDITED", + "ALSO", + "ALTERNATE", + "AND", + "ANY", + "ANYCASE", + "ARE", + "AREA", + "AREAS", + "AS", + "ASCENDING", + "ASSIGN", + "AT", + "B-AND", + "B-NOT", + "B-OR", + "B-SHIFT-L", + "B-SHIFT-LC", + "B-SHIFT-R", + "B-SHIFT-RC", + "B-XOR", + "BASED", + "BEFORE", + "BINARY", + "BINARY-CHAR", + "BINARY-DOUBLE", + "BINARY-LONG", + "BINARY-SHORT", + "BIT", + "BLANK", + "BLOCK", + "BOOLEAN", + "BOTTOM", + "BY", + "CALL", + "CANCEL", + "CF", + "CH", + "CHARACTER", + "CHARACTERS", + "CLASS", + "CLASS-ID", + "CLOSE", + "CODE", + "CODE-SET", + "COL", + "COLLATING", + "COLS", + "COLUMN", + "COLUMNS", + "COMMA", + "COMMIT", + "COMMON", + "COMP", + "COMPUTATIONAL", + "COMPUTE", + "CONDITION", + "CONFIGURATION", + "CONSTANT", + "CONTAINS", + "CONTENT", + "CONTINUE", + "CONTROL", + "CONTROLS", + "CONVERTING", + "COPY", + "CORR", + "CORRESPONDING", + "COUNT", + "CRT", + "CURRENCY", + "CURSOR", + "DATA", + "DATA-POINTER", + "DATE", + "DAY", + "DAY-OF-WEEK", + "DE", + "DECIMAL-POINT", + "DECLARATIVES", + "DEFAULT", + "DELETE", + "DELIMITED", + "DELIMITER", + "DEPENDING", + "DESCENDING", + "DESTINATION", + "DETAIL", + "DISPLAY", + "DIVIDE", + "DIVISION", + "DOWN", + "DUPLICATES", + "DYNAMIC", + "EC", + "EDITING", + "ELSE", + "EMD-START", + "END", + "END-ACCEPT", + "END-ADD", + "END-CALL", + "END-COMPUTE", + "END-DELETE", + "END-DISPLAY", + "END-DIVIDE", + "END-EVALUATE", + "END-IF", + "END-MULTIPLY", + "END-OF-PAGE", + "END-PERFORM", + "END-READ", + "END-RECEIVE", + "END-RETURN", + "END-REWRITE", + "END-SEARCH", + "END-SEND", + "END-STRING", + "END-SUBTRACT", + "END-UNSTRING", + "END-WRITE", + "ENVIRONMENT", + "EO", + "EOP", + "EQUAL", + "ERROR", + "EVALUATE", + "EXCEPTION", + "EXCEPTION-OBJECT", + "EXCLUSIVE-OR", + "EXIT", + "EXTEND", + "EXTERNAL", + "FACTORY", + "FALSE", + "FARTHEST-FROM-ZERO", + "FD", + "FILE", + "FILE-CONTROL", + "FILLER", + "FINAL", + "FINALLY", + "FIRST", + "FLOAT-BINARY-128", + "FLOAT-BINARY-32", + "FLOAT-BINARY-64", + "FLOAT-DECIMAL-16", + "FLOAT-DECIMAL-34", + "FLOAT-EXTENDED", + "FLOAT-INFINITY", + "FLOAT-LONG", + "FLOAT-NOT-A-NUMBER-", + "FLOAT-SHORT", + "FOOTING", + "FOR", + "FORMAT", + "FREE", + "FROM", + "FUNCTION", + "FUNCTION-ID", + "FUNCTION-POINTER", + "GENERATE", + "GET", + "GIVING", + "GLOBAL", + "GO", + "GOBACK", + "GREATER", + "GROUP", + "GROUP-USAGE", + "HEADING", + "HIGH-VALUE", + "HIGH-VALUES", + "I-O", + "I-OICONTROL", + "IDENTIFICATION", + "IF", + "IN", + "IN-ARITHMETIC-RANGE", + "INDEX", + "INDEXED", + "INDICATE", + "INHERITS", + "INITIAL", + "INITIALIZE", + "INITIATE", + "INPUT", + "INPUT-OUTPUT", + "INSPECT", + "INTERFACE", + "INTERFACE-ID", + "INTO", + "INVALID", + "INVOKE", + "IS", + "JUST", + "JUSTIFIED", + "KEY", + "LAST", + "LEADING", + "LEFT", + "LENGTH", + "LESS", + "LIMIT", + "LIMITS", + "LINAGE", + "LINAGE-COUNTER", + "LINE", + "LINE-COUNTER", + "LINES", + "LINKAGE", + "LOCAL-STORAGE", + "LOCALE", + "LOCATION", + "LOCK", + "LOW-VALUE", + "LOW-VALUES", + "MERGE", + "MESSAGE-TAG", + "METHOD-ID", + "MINUS", + "MODE", + "MOVE", + "MULTIPLY", + "NATIONAL", + "NATIONAL-EDITED", + "NATIVE", + "NEAREST-TO-ZERO", + "NEGATIVE", + "NESTED", + "NEXT", + "NO", + "NOT", + "NULL", + "NUMBER", + "NUMERIC", + "NUMERIC-EDITED", + "OBJECT", + "OBJECT-COMPUTER", + "OBJECT-REFERENCE", + "OCCURS", + "OF", + "OFF", + "OMITTED", + "ON", + "OPEN", + "OPTIONAL", + "OPTIONS", + "OR", + "ORDER", + "ORGANIZATION", + "OTHER", + "OUTPUT", + "OVERFLOW", + "OVERRIDE", + "PACKED-DECIMAL", + "PAGE", + "PAGE-COUNTER", + "PERFORM", + "PF", + "PH", + "PIC", + "PICTURE", + "PLUS", + "POINTER", + "POSITIVE", + "PRESENT", + "PRINTING", + "PROCEDURE", + "PROGRAM", + "PROGRAM-ID", + "PROGRAM-POINTER", + "PROPERTY", + "PROTOTYPE", + "QUIET", + "QUOTE", + "QUOTES", + "RAISE", + "RAISING", + "RANDOM", + "RD", + "READ", + "RECEIVE", + "RECORD", + "RECORDS", + "REDEFINES", + "REEL", + "REFERENCE", + "RELATIVE", + "RELEASE", + "REMAINDER", + "REMOVAL", + "RENAMES", + "REPLACE", + "REPLACING", + "REPORT", + "REPORTING", + "REPORTS", + "REPOSITORY", + "RESERVE", + "RESET", + "RESUME", + "RETRY", + "RETURN", + "RETURNING", + "REWIND", + "REWRITE", + "RF", + "RH", + "RIGHT", + "ROLLBACK", + "ROUNDED", + "RUN", + "SAME", + "SCREEN", + "SD", + "SEARCH", + "SECTION", + "SELECT", + "SELF", + "SEND", + "SENTENCE", + "SEPARATE", + "SEQUENCE", + "SEQUENTIAL", + "SET", + "SHARING", + "SIGN", + "SIGNALING", + "SIZE", + "SORT", + "SORT-MERGE", + "SOURCE", + "SOURCE-COMPUTER", + "SOURCES", + "SPACE", + "SPACES", + "SPECIAL-NAMES", + "STANDARD", + "STANDARD-1", + "STANDARD-2", + "START", + "STATUS", + "STOP", + "STRING", + "SUBTRACT", + "SUM", + "SUPER", + "SUPPRESS", + "SYMBOLIC", + "SYNC", + "SYNCHRONIZED", + "SYSTEM-DEFAULT", + "TABLE", + "TALLYING", + "TERMINATE", + "TEST", + "THAN", + "THEN", + "THROUGH", + "THRU", + "TIME", + "TIMES", + "TO", + "TOP", + "TRAILING", + "TRUE", + "TYPE", + "TYPEDEF", + "UNIT", + "UNIVERSAL", + "UNLOCK", + "UNSTRING", + "UNTIL", + "UP", + "UPON", + "USAGE", + "USE", + "USER-DEFAULT", + "USING", + "VAL-STATUS", + "VALID", + "VALIDATE", + "VALIDATE-STATUS", + "VALUE", + "VALUES", + "VARYING", + "WHEN", + "WITH", + "WORKING-STORAGE", + "WRITE", + "XOR", + "ZERO", + "ZEROES", + "ZEROS", + "+", + "-", + "*", + "/", + "**", + "<", + "<=", + "<>", + "=", + ">", + ">=", + "&", + "*>", + "::", + ">>", +}; + +// 8.10 Context-sensitive words +static const std::set<std::string> context_sensitive_words = { + "ACTIVATING", // MODULE-NAME intrinsic function + "ANUM", // CONVERT intrinsic function + "APPLY", // I-O-CONTROL paragraph + "ARITHMETIC", // OPTIONS paragraph + "ATTRIBUTE", // SET statement + "AUTO", // screen description entry + "AUTOMATIC", // LOCK MODE clause + "AWAY-FROM-ZERO", // ROUNDED phrase + "BACKGROUND-COLOR", // screen description entry + "BACKWARD", // INSPECT statement + "BELL", // screen description entry and SET attribute statement + "BINARY-ENCODING", // USAGE clause and FLOAT-DECIMAL clause + "BLINK", // screen description entry and SET attribute statement + "BYTE", // CONVERT intrinsic function + "BYTES", // RECORD clause + "BYTE-LENGTH", // constant entry + "CAPACITY", // OCCURS clause + "CENTER", // COLUMN clause + "CLASSIFICATION", // OBJECT-COMPUTER paragraph + "CURRENT", // MODULE-NAME intrinsic function + "CYCLE", // EXIT statement + "DECIMAL-ENCODING", // USAGE clause and FLOAT-DECIMAL clause + "EOL", // ERASE clause in a screen description entry + "EOS", // ERASE clause in a screen description entry + "ENTRY-CONVENTION", // OPTIONS paragraph + "ERASE", // screen description entry + "EXPANDS", // class-specifier and interface-specifier of the REPOSITORY paragraph + "FLOAT-BINARY", // OPTIONS paragraph + "FLOAT-DECIMAL", // OPTIONS paragraph + "FOREGROUND-COLOR", // screen description entry + "FOREVER", // RETRY phrase + "FULL", // screen description entry + "HEX", // CONVERT intrinsic function + "HIGH-ORDER-LEFT", // FLOAT-BINARY clause, FLOAT-DECIMAL clause, and USAGE clause + "HIGH-ORDER-RIGHT", // FLOAT-BINARY clause, FLOAT-DECIMAL clause, and USAGE clause + "HIGHLIGHT", // screen description entry and SET attribute statement + "IGNORING", // READ statement + "IMPLEMENTS", // FACTORY paragraph and OBJECT paragraph + "INITIALIZED", // ALLOCATE statement and OCCURS clause + "INTERMEDIATE", // OPTIONS paragraph + "INTRINSIC", // function-specifier of the REPOSITORY paragraph + "LC_ALL", // SET statement + "LC_COLLATE", // SET statement + "LC_CTYPE", // SET statement + "LC_MESSAGES", // SET statement + "LC_MONETARY", // SET statement + "LC_NUMERIC", // SET statement + "LC_TIME", // SET statement + "LOWLIGHT", // screen description entry and SET attribute statement + "MANUAL", // LOCK MODE clause + "MULTIPLE", // LOCK ON phrase + "NAT", // CONVERT intrinsic function + "NEAREST-AWAY-FROM-ZERO", // INTERMEDIATE ROUNDING clause and ROUNDED phrase + "NEAREST-EVEN", // INTERMEDIATE ROUNDING clause and ROUNDED phrase + "NEAREST-TOWARD-ZERO", // INTERMEDIATE ROUNDING clause and ROUNDED phrase + "NONE", // DEFAULT clause + "NORMAL", // STOP statement + "NUMBERS", // COLUMN clause and LINE clause + "ONLY", // Object-view, SHARING clause, SHARING phrase, and USAGE clause + "PARAGRAPH", // EXIT statement + "PREFIXED", // DYNAMIC LENGTH STRUCTURE clause + "PREVIOUS", // READ statement + "PROHIBITED", // INTERMEDIATE ROUNDING clause and ROUNDED phrase + "RECURSIVE", // PROGRAM-ID paragraph + "RELATION", // VALIDATE-STATUS clause + "REQUIRED", // screen description entry + "REVERSE-VIDEO", // screen description entry and SET attribute statement + "ROUNDING", // OPTIONS paragraph + "SECONDS", // RETRY phrase, CONTINUE statement + "SECURE", // screen description entry + "SHORT", // DYNAMIC LENGTH STRUCTURE clause + "SIGNED", // DYNAMIC LENGTH STRUCTURE clause and USAGE clause + "STACK", // MODULE-NAME intrinsic function + "STANDARD-BINARY", // ARITHMETIC clause + "STANDARD-DECIMAL", // ARITHMETIC clause + "STATEMENT", // RESUME statement + "STEP", // OCCURS clause + "STRONG", // TYPEDEF clause + "STRUCTURE", // DYNAMIC LENGTH STRUCTURE clause + "SYMBOL", // CURRENCY clause + "TOP-LEVEL", // MODULE-NAME intrinsic function + "TOWARD-GREATER", // ROUNDED phrase + "TOWARD-LESSER", // ROUNDED phrase + "TRUNCATION", // INTERMEDIATE ROUNDING clause and ROUNDED phrase + "UCS-4", // ALPHABET clause + "UNDERLINE", // screen description entry and SET attribute statement + "UNSIGNED", // USAGE clause + "UTF-8", // ALPHABET clause + "UTF-16", // ALPHABET clause + "YYYYDDD", // ACCEPT statement + "YYYYMMDD", // ACCEPT statement +}; + +// Is the input a COBOL word, per ISO/IEC 1989:2023 (E) ? +// We add a few GCC-specific keywords, and our supported IBM keywords. +bool +iso_cobol_word( const std::string& name, bool include_context ) { + auto ok = 1 == reserved_words.count(name); + if( include_context && !ok ) { + ok = 1 == context_sensitive_words.count(name); + } + return ok; +} + diff --git a/gcc/cobol/util.h b/gcc/cobol/util.h index eb08ed7..165915a 100644 --- a/gcc/cobol/util.h +++ b/gcc/cobol/util.h @@ -31,19 +31,33 @@ #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); 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 |