diff options
Diffstat (limited to 'gcc/cobol')
47 files changed, 18557 insertions, 10911 deletions
diff --git a/gcc/cobol/ChangeLog b/gcc/cobol/ChangeLog index be421d2..67518ac 100644 --- a/gcc/cobol/ChangeLog +++ b/gcc/cobol/ChangeLog @@ -1,3 +1,2487 @@ +2025-12-03 Jakub Jelinek <jakub@redhat.com> + + * lang.opt: Make sure all option descriptions are terminated with + a dot. + (preprocess): Capitalize first letter of option description. + +2025-12-01 James K. Lowden <jklowden@cobolworx.com> + + PR cobol/119329 + PR cobol/119331 + PR cobol/120786 + * Make-lang.in: Add cobol/messages.o to cobol1 sources. + * cbldiag.h (yywarn): Remove function. + (struct cbl_loc_t): Introduce new location type independent of Bison. + (enum cbl_diag_id_t): Enumerate diagnostic messages. + (cbl_message): New function. + (dialect_ok): Test for dialect, emit standard message. + (dialect_not_ok): Emit standard message if syntax excluded by dialect. + (dialect_error): Remove function. + (cbl_unimplementedw): Use cbl_diag_id_t. + (cbl_unimplemented): Whitespace. + * cdf.y: Update token values. + * cobol1.cc (enable_exceptions): Use cbl_message. + (cobol_warning): Declare function. + (cobol_langhook_handle_option): Add 44 new warning options. + (cobol_langhook_type_for_mode): Remove function. + * except.cc (cbl_enabled_exception_t::dump): Remove function. + * exceptg.h (class exception_turn_t): Use cbl_diag_id_t. + * gcobol.1: Document dialect syntax and new warning options. + * genapi.cc (parser_label_label): Remove unused warning. + * gengen.cc (gg_find_field_in_struct): Use cbl_internal_error. + (gg_printf): Same. + (gg_fprintf): Same. + (gg_define_function): Same. + (gg_get_function_decl): Same. + (gg_call_expr): Same. + (gg_call): Same. + * lang-specs.h: Add warning options. + * lang.opt: Add ISO dialect and options. + * lexio.cc (parse_replacing_term): Use cbl_message. + (parse_replacing_pair): Same. + (preprocess_filter_add): Same. + (cdftext::echo_input): Same. + (cdftext::lex_open): Same. + (cdftext::open_input): Same. + * messages.cc: New file implements cbl_message. + * parse.y: Use cbl_message. + * parse_ante.h (dialect_proscribed): Remove function. + (parser_move_carefully): Use dialect_ok. + (goodnight_gracie): Convert warning to debug message. + * scan.l: Use dialect_ok. + * scan_ante.h (scanner_parsing): Use cbl_diag_id_t. + (scanner_parsing_toggle): Same. + (scanner_parsing_pop): Same. + (verify_ws): Same. + (level_of): Same. + (typed_name): Same. + (integer_of): Same. + * scan_post.h (datetime_format_of): Use cbl_internal_error. + (prelex): Emit only debug messages. + * show_parse.h: Use cbl_internal_error. + * symbols.cc (symbols_update): Remove dialect test because parser's problem. + (cbl_field_t::internalize): Use cbl_message. + * symbols.h (enum cbl_dialect_t): Add ISO to cbl_dialect_t. + (cbl_dialect_str): Recognize ISO dialect. + (dialect_has): New function. + (cbl_diagnostic_kind): New function. + (cbl_dialect_kind): New function. + (struct cbl_alphabet_t): Emit only debug message. + * token_names.h: Regenerate. + * util.cc (gb4): Emit only debug message. + (current_token_location): Add overload to set token_location. + (yywarn): Remove function. + (cobol_fileline_set): Use cbl_message. + (cobol_parse_files): Same. + (cbl_message): New diagnostic message function uses cbl_diag_id_t. + (cbl_diagnostic_kind): New function. + (cbl_diagnostic_option): New function. + (cbl_unimplementedw): Use cbl_diag_id_t. + (dialect_error): Remove function. + * util.h (cbl_message): Remove obsolete prototype for cbl_message. + +2025-11-30 Andrew Pinski <andrew.pinski@oss.qualcomm.com> + + * lang.opt.urls: Regenerate. + +2025-11-17 James K. Lowden <jklowden@cobolworx.com> + + PR cobol/122702 + * Make-lang.in: Move stored-char-length.cbl to libgcobol. + +2025-11-17 Jakub Jelinek <jakub@redhat.com> + + * symbols.cc (symbol_table_init): Avoid arithmetics or + bitwise operations between enumerators from different enums. + +2025-11-15 Jakub Jelinek <jakub@redhat.com> + + PR cobol/122691 + * lexio.cc (parse_replace_pairs): Replace parsed.stmt.p with + parsed.stmt.size() ? parsed.stmt.p : "" in the last argument to + dbgmsg. + +2025-11-13 James K. Lowden <jklowden@cobolworx.com> + + * cdf.y: Install literals in symbol table. + * genapi.cc (parser_alphabet): Use std::string for currency. + (initialize_the_data): Rely on constructor. + (parser_file_add): Better #pragma message. + (parser_exception_file): Return early if not generating code. + * parse.y: Allow library programs to act as functions. + * parse_ante.h (dialect_proscribed): Standardize message. + (intrinsic_call_2): Correct s/fund/func/ misspelling. + * scan.l: Comment. + * symbols.cc (symbols_update): Add unreachable assertion. + (symbol_field_parent_set): Reduce error to debug message. + (cdf_literalize): Declare. + (symbol_table_init): Insert CDF constants as literals. + * symbols.h (cbl_dialect_str): Provide string values for enum. + (is_working_storage): Remove function. + (struct cbl_field_data_t): Add manhandle_initial for Numeric Edited. + (struct cbl_field_t): Initialize name to zeros. + (struct cbl_section_t): Delete unused attr() function. + (symbol_unique_index): Declare. + * token_names.h: Regenerate. + * util.cc (cdf_literalize): Construct a cbl_field_t from a CDF literal. + (symbol_unique_index): Supply "globally" unique number for a program. + +2025-11-10 Sandra Loosemore <sloosemore@baylibre.com> + + PR other/122243 + * lang.opt.urls: Regenerated. + +2025-11-06 Robert Dubner <rdubner@symas.com> + James K. Lowden <jklowden@cobolworx.com> + + * Make-lang.in: Repair documentation generation. + * cdf.y: Changes to tokens. + * cobol1.cc (cobol_langhook_handle_option): Add comment. + * genapi.cc (function_pointer_from_name): Use data.original() for + function name. + (parser_initialize_programs): Likewise. + (cobol_compare): Make sure encodings of comparands are the same. + (move_tree): Change name of DEFAULT_SOURCE_ENCODING macro. + (parser_enter_program): Typo. + (psa_FldLiteralN): Break out dirty_to_binary() support routine. + (dirty_to_binary): Likewise. + (parser_alphabet): Rename 'alphabet' to 'collation_sequence'. + (parser_allocate): Change wsclear() to be uint32_t instead of char. + (parser_label_label): Formatting. + (parser_label_goto): Likewise. + (get_the_filename): Breakout get_the_filename(), which handles + encoding. + (parser_file_open): Likewise. + (set_up_delete_file_label): Implement DELETE FILE (Format 2). + (parser_file_delete_file): Likewise. + (parser_file_delete_on_exception): Likewise. + (parser_file_delete_not_exception): Likewise. + (parser_file_delete_end): Likewise. + (parser_call): Use data.original(). + (parser_entry): Use data.original(). + (mh_source_is_literalN): Convert from + sourceref.field->codeset.encoding. + (binary_initial_from_float128): Change to "binary_initial". + (binary_initial): Calculate in FIXED_WIDE_INT(128) instead of + REAL_VALUE_TYPE. + (digits_from_int128): New routine uses binary_initial. + (digits_from_float128): Removed. Kept as comment for reference. + (initial_from_initial): Use binary_initial. + (actually_create_the_static_field): Use correct encoding. + (parser_symbol_add): Likewise. + * genapi.h (parser_file_delete_file): Implement FILE DELETE. + (parser_file_delete_on_exception): Implement FILE DELETE. + (parser_file_delete_not_exception): Implement FILE DELETE. + (parser_file_delete_end): Implement FILE DELETE. + * genmath.cc: Include charmaps.h. + * genutil.cc (get_literal_string): Change name of + DEFAULT_SOURCE_ENCODING macro. + * parse.y: Token changes; numerous changes in support of encoding; + support for DELETE FILE. + * parse_ante.h (name_of): Use data.original(). + (class prog_descr_t): Support of locales. + (current_options): Formatting. + (current_encoding): Formatting. + (current_program_index): Formatting. + (current_section): Formatting. + (current_paragraph): Formatting. + (is_integer_literal): Use correct encoding. + (value_encoding_check): Handle encoding changes. + (alphabet_add): Likewise. + (data_division_ready): Likewise. + * scan.l: Use data.original(). + * show_parse.h: Use correct encoding. + * symbols.cc (elementize): Likewise. + (symbol_elem_cmp): Handle locale. + (struct symbol_elem_t): Likewise. + (symbol_locale): Likewise. + (field_str): Change DEFAULT_SOURCE_ENCODING macro name. + (symbols_alphabet_set): Formatting. + (symbols_update): Modify consistency checks. + (symbol_locale_add): Locale support. + (cbl_locale_t::cbl_locale_t): Locale support. + (cbl_alphabet_t::cbl_alphabet_t): New structure. + (cbl_alphabet_t::reencode): Formatting. + (cbl_alphabet_t::assign): Change name of collation_sequence. + (cbl_alphabet_t::also): Likewise. + (new_literal_add): Anticipate the need for four-byte characters. + (guess_encoding): Eliminate. + (cbl_field_t::internalize): Refine conversion of data.initial to + specified encoding. + * symbols.h (enum symbol_type_t): Add SymLocale. + (struct cbl_field_data_t): Incorporate data.orig. + (struct cbl_field_t): Likewise. + (struct cbl_delete_file_t): New structure. + (struct cbl_label_t): Incorporate cbl_delete_file_t. + (struct cbl_locale_t): Support for locale. + (hex_decode): Comment. + (struct cbl_alphabet_t): Incorporate locale; change variable name + to collation_sequence. + (struct symbol_elem_t): Incorporate locale. + (cbl_locale_of): Likewise. + (cbl_alphabet_of): Likewise. + (symbol_locale_add): Likewise. + (wsclear): Type is now uint32_t instead of char. + * util.cc (symbol_type_str): Incorporate locale. + (cbl_field_t::report_invalid_initial_value): Change test so that + pure PIC A() variables are limited to [a-zA-Z] and space. + (valid_move): Use DEFAULT_SOURCE_ENCODING macro. + (cobol_filename): Formatting. + +2025-10-26 Eric Botcazou <ebotcazou@adacore.com> + + * Make-lang.in ($(srcdir)/cobol/token_names.h): Silence recipe. + +2025-10-23 Robert Dubner <rdubner@symas.com> + + * genapi.cc (parser_alphabet): Alphabet encoding. + (parser_alphabet_use): Likewise. + (parser_xml_parse): Use correct debugging macro; encoding. + (parser_xml_on_exception): Likewise. + (parser_xml_not_exception): Likewise. + (parser_xml_end): Likewise. + (initialize_the_data): Encoding. + (parser_label_label): Debugging macros. + (parser_label_goto): Likewise. + (parser_file_add): Encoding. + (parser_intrinsic_call_1): Special handling for __gg__char. + (parser_intrinsic_call_2): Formatting. + * parse.y: Response from FUNCTION ORD is flagged "unsigned". + * symbols.cc (cbl_alphabet_t::reencode): Establish + low_char & high_char. + * symbols.h (struct cbl_alphabet_t): Likewise. + +2025-10-23 Robert Dubner <rdubner@symas.com> + James K. Lowden <jklowden@cobolworx.com> + + * Make-lang.in: Incorporate new token_names.h file. + * cdf.y: Modify tokens. + * gcobol.1: Document XML PARSE statement + * genapi.cc (parser_enter_program): Verify that every goto has a + matching label. + (parser_end_program): Likewise. + (parser_alphabet): Refine handling codeset encodings. + (parser_alphabet_use): Likewise. + (label_fetch): Moved from later in the source code. + (parser_xml_parse): New routine for XML PARSE. + (parser_xml_on_exception): Likewise. + (parser_xml_not_exception): Likewise. + (parser_xml_end): Likewise. + (parser_label_label): Verify goto/label matching. + (parser_label_goto): Likewise. + (parser_entry): Minor change to SHOW_PARSE report. + * genapi.h (parser_alphabet): Set parameter to const. + (parser_xml_parse): Declare new function. + (parser_xml_on_exception): Likewise. + (parser_xml_not_exception): Likewise. + (parser_xml_end): Likewise. + (parser_label_addr): Likewise. + * parse.y: label_pair_t structure; locale processing; new token + processing for alphabets and XML PARSE. + * parse_ante.h (name_of): Return field->name when initial is NULL. + (new_tempnumeric): Make signable_e optional. + (ast_save_locale): New function. + (data_division_ready): Warning for "no alphabet". + * scan.l: Repair interpretation of BINARY, COMP, COMP-4, and + COMP-5. + * scan_ante.h (struct bint_t): Likewise. + * scan_post.h (current_tokens_t::tokenset_t::tokenset_t): + Include token_names.h. + * symbols.cc (symbols_alphabet_set): Revert to prior alphabet + determination. + (symbol_table_init): New XML special registers. + (new_temporary): Make signable_e controllable, not fixed. + * symbols.h (__gg__encoding_iconv_valid): New declaration. + (enum cbl_label_type_t): New LblXml label type. + (struct cbl_xml_parse_t): + (struct cbl_label_t): Implement XML PARSE. + (new_temporary): Incorporate boolean for signable_e. + (symbol_elem_of): Change label field type handling. + (cbl_section_of): Likewise. + (cbl_field_of): Likewise. + (cbl_label_of): Likewise. + (cbl_special_name_of): Likewise. + (cbl_alphabet_of): Likewise. + (cbl_file_of): Likewise. + * token_names.h: New file. + * util.cc (gcc_location_set_impl): Improve location_t calculations + when entering and leaving COPYBOOKs. + +2025-10-19 Robert Dubner <rdubner@symas.com> + + * genapi.cc (move_tree): Formatting. + (parser_enter_file): Incorporate global __gg__entry_label. + (enter_program_common): Remove calls to alphabet overrides. + (parser_alphabet): Change cbl_alphabet_e handling. + (parser_alphabet_use): Likewise. + (initialize_the_data): Likewise. + (establish_using): Process passed parameters in a subroutine. + (parser_division): Remove in-line parameter processing; + call establish_using() instead. Check for __gg__entry_label. + (parser_file_add): Temporary workaround for charset encoding. + (parser_file_open): Likewise. + (create_and_call): Push/pop program state around call to external. + (parser_entry): Implement new ENTRY statement feature. + (mh_source_is_literalN): Formatting. + * genapi.h (parser_entry): New ENTRY statement. + * gengen.cc (gg_create_goto_pair): Formatting. + (gg_goto_label_decl): Remove. + * gengen.h (gg_goto_label_decl): Remove. + * genutil.cc (internal_codeset_is_ebcdic): Remove. + * genutil.h (internal_codeset_is_ebcdic): Remove. + * symbols.cc (symbols_alphabet_set): Restrict alphabet scan to + program. + * symbols.h (is_elementary): Use defined constants instead of + explicit 'A'and 'N' + +2025-10-10 Robert Dubner <rdubner@symas.com> + + * cdf.y: In support of the described changes. + * gcobol.1: Likewise. + * genapi.cc (level_88_helper): Likewise. + (get_level_88_domain): Likewise. + (get_class_condition_string): Likewise. + (initialize_variable_internal): Likewise. + (gg_default_qualification): Likewise. + (cobol_compare): Likewise. + (move_tree): Likewise. + (move_tree_to_field): Likewise. + (psa_FldBlob): Likewise. + (parser_accept_date_yymmdd): Likewise. + (parser_accept_date_yyyymmdd): Likewise. + (parser_accept_date_yyddd): Likewise. + (parser_accept_date_yyyyddd): Likewise. + (parser_accept_date_dow): Likewise. + (parser_accept_date_hhmmssff): Likewise. + (parser_alphabet): Likewise. + (parser_alphabet_use): Likewise. + (parser_display_internal): Likewise. + (parser_display): Likewise. + (is_valuable): Likewise. + (parser_division): Likewise. + (parser_relop_long): Likewise. + (parser_setop): Likewise. + (parser_set_conditional88): Likewise. + (parser_file_add): Likewise. + (parser_file_open): Likewise. + (create_and_call): Likewise. + (parser_call): Likewise. + (mh_identical): Likewise. + (mh_source_is_literalN): Likewise. + (picky_memcpy): Likewise. + (mh_numeric_display): Likewise. + (mh_source_is_group): Likewise. + (mh_source_is_literalA): Likewise. + (move_helper): Likewise. + (initial_from_initial): Likewise. + (actually_create_the_static_field): Likewise. + (psa_FldLiteralA): Likewise. + (parser_symbol_add): Likewise. + * genmath.cc (arithmetic_operation): Likewise. + * genutil.cc (get_binary_value): Likewise. + (get_literal_string): Likewise. + * genutil.h (EBCDIC_MINUS): Likewise. + (EBCDIC_PLUS): Likewise. + (EBCDIC_ZERO): Likewise. + (EBCDIC_NINE): Likewise. + * parse.y: Likewise. + * parse_ante.h (name_of): Likewise. + (class prog_descr_t): Likewise. + (current_encoding): Likewise. + (needs_picture): Likewise. + (is_callable): Likewise. + (field_attr_str): Likewise. + (value_encoding_check): Likewise. + (field_alloc): Likewise. + (file_add): Likewise. + * scan.l: Likewise. + * structs.cc (create_cblc_field_t): Likewise. + * symbols.cc (elementize): Likewise. + (cbl_field_attr_str): Likewise. + (is_variable_length): Likewise. + (field_str): Likewise. + (extend_66_capacity): Likewise. + (assert): Likewise. + (symbols_update): Likewise. + (symbol_field_parent_set): Likewise. + (add_token): Likewise. + (symbol_table_init): Likewise. + (symbol_field_add): Likewise. + (symbol_field_forward_add): Likewise. + (symbol_field_same_as): Likewise. + (cbl_alphabet_t::reencode): Likewise. + (new_temporary_impl): Likewise. + (parser_symbol_add2): Likewise. + (new_literal_add): Likewise. + (temporaries_t::literal): Likewise. + (new_literal): Likewise. + (standard_internal): Likewise. + (new_temporary): Likewise. + (cbl_field_t::holds_ascii): Likewise. + (cbl_field_t::is_ascii): Likewise. + (cbl_field_t::internalize): Likewise. + (symbol_label_add): Likewise. + (symbol_label_section_exists): Likewise. + (cbl_occurs_t::subscript_ok): Likewise. + (cbl_file_t::deforward): Likewise. + (has_value): Likewise. + * symbols.h (is_numeric): Likewise. + (__gg__encoding_iconv_name): Likewise. + (current_encoding): Likewise. + (struct cbl_field_t): Likewise. + (new_literal): Likewise. + (class temporaries_t): Likewise. + (struct function_descr_t): Likewise. + (hex_decode): Likewise. + (struct cbl_alphabet_t): Likewise. + (struct cbl_file_t): Likewise. + * symfind.cc (field_structure): Likewise. + (erase_symbol_map_fwds): Likewise. + (symbol_find): Likewise. + * token_names.h: Likewise. + * util.cc (cbl_field_type_str): Likewise. + (is_elementary): Likewise. + (symbol_field_type_update): Likewise. + (cbl_field_t::report_invalid_initial_value): Likewise. + (valid_move): Likewise. + (valid_picture): Likewise. + (type_capacity): Likewise. + (gcc_location_set_impl): Likewise. + (cbl_unimplementedw): Likewise. + +2025-09-05 Robert Dubner <rdubner@symas.com> + + * genapi.cc (trace1_init): Prepend two internal variables with + underscore. + (initialize_variable_internal): Use new register_e attribute. + (psa_global): Use "__ggsr__" prefix to identify special registers + (parser_symbol_add): Use new register_e attribute. + * symbols.cc (cbl_field_attr_str): Likewise. + (symbol_table_init): Likewise. + (is_register_field): Eliminated in favor of (attr & register_e). + * symbols.h (is_register_field): Likewise. + +2025-08-20 Robert Dubner <rdubner@symas.com> + + * genutil.cc (get_binary_value): Fix a comment. + * parse.y: udf_args_valid(): Fix loc calculation. + * symbols.cc (assert): extend_66_capacity(): Avoid assert(e < e2) in + -O0 build until symbol_table expansion is fixed. + +2025-08-15 Robert Dubner <rdubner@symas.com> + + * genapi.h (parser_call_exception_end): Remove obsolete comment. + * structs.cc (create_cbl_enabled_exception_t): + Remove cbl_enabled_exception_type_node; + remove create_cbl_enabled_exception_t(). + (create_our_type_nodes): Likewise. + * structs.h (GTY): Likewise. + +2025-08-13 Robert Dubner <rdubner@symas.com> + + * genutil.cc (get_binary_value): Use the new routine. + +2025-08-13 Robert Dubner <rdubner@symas.com> + + * genutil.cc (get_binary_value): Use the new routine. + +2025-08-12 Robert Dubner <rdubner@symas.com> + + * genapi.cc (compare_binary_binary): Formatting. + (cobol_compare): Formatting. + (mh_numeric_display): Rewrite "move ND to ND" algorithm. + (initial_from_initial): Proper initialization of EBCDIC ND variables. + * genmath.cc (fast_add): Delete comment. + * genutil.cc (get_binary_value): Modify for updated EBCDIC. + +2025-08-07 Robert Dubner <rdubner@symas.com> + + * cbldiag.h (location_dump): Source code formatting. + * parse.y: error_msg formatting. + * scan.l: Remove UTF-8 character from regex pattern. + * scan_ante.h (numstr_of): error_msg formatting. + * show_parse.h (class ANALYZE): Suppress cppcheck error. + * util.cc (cbl_field_t::report_invalid_initial_value): + error_msg formatting. + +2025-08-02 Jakub Jelinek <jakub@redhat.com> + + * parse.y (intrinsic): Use %td format specifier with no cast on + argument instead of %ld with cast to long. + * scan_ante.h (numstr_of): Likewise. + * util.cc (cbl_field_t::report_invalid_initial_value): Likewise. + +2025-08-01 Robert Dubner <rdubner@symas.com> + + PR cobol/119324 + * cbldiag.h (location_dump): Inline suppression of knownConditionTrueFalse. + * genapi.cc (parser_statement_begin): Combine two if() statements. + * genutil.cc (get_binary_value): File-level suppression of duplicateBreak. + * symbols.cc (symbol_elem_cmp): File-level suppression of duplicateBreak. + +2025-07-31 Robert Dubner <rdubner@symas.com> + + PR cobol/120244 + * genapi.cc (get_level_88_domain): Increase array size for final byte. + (psa_FldLiteralA): Use correct length in build_string_literal call. + * scan.l: Use a loop instead of std:transform to avoid EOF overrun. + * scan_ante.h (binary_integer_usage): Use a variable-length buffer. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * util.cc: Update for diagnostic_t becoming + enum class diagnostics::kind. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * util.cc: Update for renaming of diagnostic_option_id to + diagnostics::option_id. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * util.cc: Remove redundant #includes + +2025-07-24 Robert Dubner <rdubner@symas.com> + + PR cobol/119231 + * gcobolspec.cc: (lang_specific_driver): Pass OPT_static through. + Handle -static and -static-libgcobol properly. + +2025-07-23 Robert Dubner <rdubner@symas.com> + + * genapi.cc (leave_procedure): Adjust location_t for PERFORM. + (parser_perform_times): Likewise. + (internal_perform_through_times): Likewise. + (perform_outofline_before_until): Likewise. + (perform_outofline_after_until): Likewise. + (perform_outofline_testafter_varying): Likewise. + (perform_outofline_before_varying): Likewise. + +2025-07-21 Robert Dubner <rdubner@symas.com> + James K. Lowden <jklowden@cobolworx.com> + + PR cobol/120402 + * Make-lang.in: Elminate commented-out scripting. + * cbldiag.h (_CBLDIAG_H): Change #if 0 to #if GCOBOL_GETENV + (warn_msg): Add printf attributes. + (location_dump): Add debugging message. + * cdf.y: Improved linemap tracking. + * genapi.cc (treeplet_fill_source): const attribute for formal parameter. + (insert_nop): Created to consolidate var_decl_nop writes. + (build_main_that_calls_something): Move generation to the end of executable. + (level_88_helper): Formatting. + (parser_call_targets_dump): Formatting. + (function_pointer_from_name): const attribute for formal parameter. + (parser_initialize_programs): const attribute for formal parameter. + (parser_statement_begin): Improved linemap handling. + (section_label): Improved linemap handling. + (paragraph_label): Improved linemap handling. + (pseudo_return_pop): Improved linemap handling. + (leave_procedure): Formatting. + (parser_enter_section): Improved linemap handling. + (parser_enter_paragraph): Improved linemap handling. + (parser_perform): Formatting. + (parser_leave_file): Move creation of main() to this routine. + (parser_enter_program): Move creation of main from here to leave_file. + (parser_accept): Formatting. const attribute for formal parameter. + (parser_accept_command_line): const attribute for formal parameter. + (parser_accept_command_line_count): const attribute for formal parameter. + (parser_accept_envar): Likewise. + (parser_set_envar): Likewise. + (parser_display): Likewise. + (get_exhibit_name): Implement EXHIBIT verb. + (parser_exhibit): Likewise. + (parser_sleep): const attribute for formal parameter. + (parser_division): Improved linemap handling. + (parser_classify): const attribute for formal parameter. + (create_iline_address_pairs): Improved linemap handling. + (parser_perform_start): Likewise. + (perform_inline_until): Likewise. + (perform_inline_testbefore_varying): Likewise. + (parser_perform_until): Likewise. + (parser_perform_inline_times): Likewise. + (parser_intrinsic_subst): const attribute for formal parameter. + (parser_file_merge): Formatting. + (create_and_call): Improved linemap handling. + (mh_identical): const attribute for formal parameter. + (mh_numeric_display): const attribute for formal parameter. + (mh_little_endian): Likewise. + (mh_source_is_group): Likewise. + (psa_FldLiteralA): Formatting. + * genapi.h (parser_accept): const attribute for formal parameter. + (parser_accept_envar): Likewise. + (parser_set_envar): Likewise. + (parser_accept_command_line): Likewise. + (parser_accept_command_line_count): Likewise. + (parser_add): Likewise. + (parser_classify): Likewise. + (parser_sleep): Likewise. + (parser_exhibit): Likewise. + (parser_display): Likewise. + (parser_initialize_programs): Likewise. + (parser_intrinsic_subst): Likewise. + * gengen.cc (gg_assign): Improved linemap handling. + (gg_add_field_to_structure): Likewise. + (gg_define_from_declaration): Likewise. + (gg_build_relational_expression): Likewise. + (gg_goto_label_decl): Likewise. + (gg_goto): Likewise. + (gg_printf): Likewise. + (gg_fprintf): Likewise. + (gg_memset): Likewise. + (gg_memchr): Likewise. + (gg_memcpy): Likewise. + (gg_memmove): Likewise. + (gg_strcpy): Likewise. + (gg_strcmp): Likewise. + (gg_strncmp): Likewise. + (gg_return): Likewise. + (chain_parameter_to_function): Likewise. + (gg_define_function): Likewise. + (gg_get_function_decl): Likewise. + (gg_call_expr): Likewise. + (gg_call): Likewise. + (gg_call_expr_list): Likewise. + (gg_exit): Likewise. + (gg_abort): Likewise. + (gg_strlen): Likewise. + (gg_strdup): Likewise. + (gg_malloc): Likewise. + (gg_realloc): Likewise. + (gg_free): Likewise. + (gg_set_current_line_number): Likewise. + (gg_get_current_line_number): Likewise. + (gg_insert_into_assembler): Likewise. + (token_location_override): Likewise. + (gg_token_location): Likewise. + * gengen.h (location_from_lineno): Likewise. + (gg_set_current_line_number): Likewise. + (gg_get_current_line_number): Likewise. + (gg_token_location): Likewise. + (current_token_location): Likewise. + (current_location_minus_one): Likewise. + (current_location_minus_one_clear): Likewise. + (token_location_override): Likewise. + * genmath.cc (fast_divide): const attribute for formal parameter. + * genutil.cc (get_and_check_refstart_and_reflen): Likewise. + (get_data_offset): Likewise. + (refer_refmod_length): Likewise. + (refer_offset): Likewise. + (refer_size): Likewise. + (refer_size_dest): Likewise. + (refer_size_source): Likewise. + (qualified_data_location): Likewise. + * genutil.h (refer_offset): Likewise. + (refer_size_source): Likewise. + (refer_size_dest): Likewise. + (qualified_data_location): Likewise. + * parse.y: EVALUATE token; Implement EXHIBIT verb; + Improved linemap handling. + * parse_ante.h (input_file_status_notify): Improved linemap handling. + (location_set): Likewise. + * scan.l: PICTURE string validation. + * scan_ante.h (class picture_t): PICTURE string validation. + (validate_picture): Likewise. + * symbols.cc (symbol_currency): Revised default currency handling. + * symbols.h (symbol_currency): Likewise. + * util.cc (location_from_lineno): Improved linemap handling. + (current_token_location): Improved linemap handling. + (current_location_minus_one): Improved linemap handling. + (current_location_minus_one_clear): Improved linemap handling. + (gcc_location_set_impl): Improved linemap handling. + (warn_msg): Improved linemap handling. + * util.h (cobol_lineno): Improved linemap handling. + +2025-07-15 Jakub Jelinek <jakub@redhat.com> + Jason Merrill <jason@redhat.com> + + PR c/44677 + * gcobolspec.cc (lang_specific_driver): Remove unused but set variable + n_cobol_files. + +2025-07-14 Robert Dubner <rdubner@symas.com> + + * cobol1.cc (cobol_langhook_handle_option): Eliminate cppcheck warnings. + * dts.h: Likewise. + * except.cc (cbl_enabled_exceptions_t::dump): Likewise. + * gcobolspec.cc (lang_specific_driver): Likewise. + * genapi.cc (parser_file_merge): Likewise. + * gengen.cc (gg_unique_in_function): Likewise. + (gg_declare_variable): Likewise. + (gg_peek_fn_decl): Likewise. + (gg_define_function): Likewise. + * genmath.cc (set_up_on_exception_label): Likewise. + (set_up_compute_error_label): Likewise. + (arithmetic_operation): Likewise. + (fast_divide): Likewise. + * genutil.cc (get_and_check_refstart_and_reflen): Likewise. + (get_depending_on_value_from_odo): Likewise. + (get_data_offset): Likewise. + (get_binary_value): Likewise. + (process_this_exception): Likewise. + (copy_little_endian_into_place): Likewise. + (refer_is_clean): Likewise. + (refer_fill_depends): Likewise. + * genutil.h (process_this_exception): Likewise. + (copy_little_endian_into_place): Likewise. + (refer_is_clean): Likewise. + * lexio.cc (check_push_pop_directive): Likewise. + (check_source_format_directive): Likewise. + (location_in): Likewise. + (lexer_input): Likewise. + (cdftext::lex_open): Likewise. + (lexio_dialect_mf): Likewise. + (valid_sequence_area): Likewise. + (cdftext::free_form_reference_format): Likewise. + (cdftext::segment_line): Likewise. + * lexio.h (struct span_t): Likewise. + * scan_ante.h (trim_location): Likewise. + * symbols.cc (symbol_elem_cmp): Likewise. + (symbol_alphabet): Likewise. + (end_of_group): Likewise. + (cbl_field_t::attr_str): Likewise. + (symbols_update): Likewise. + (symbol_typedef_add): Likewise. + (symbol_field_add): Likewise. + (new_temporary_impl): Likewise. + (symbol_label_section_exists): Likewise. + (symbol_program_callables): Likewise. + (file_status_status_of): Likewise. + * symfind.cc (is_data_field): Likewise. + (finalize_symbol_map2): Likewise. + (class in_scope): Likewise. + (symbol_match2): Likewise. + * util.cc (get_current_dir_name): Likewise. + (gb4): Likewise. + (class cdf_directives_t): Likewise. + (cbl_field_t::report_invalid_initial_value): Likewise. + (literal_subscript_oob): Likewise. + (cbl_refer_t::str): Likewise. + (date_time_fmt): Likewise. + (class unique_stack): Likewise. + (cobol_set_pp_option): Likewise. + (cobol_filename): Likewise. + (cobol_filename_restore): Likewise. + (gcc_location_set_impl): Likewise. + (ydferror): Likewise. + (error_msg_direct): Likewise. + (yyerror): Likewise. + (cbl_unimplemented_at): Likewise. + +2025-07-13 Robert Dubner <rdubner@symas.com> + + * Make-lang.in: Eliminate the .cc.o override. + * genapi.cc (level_88_helper): Eliminate cppcheck warning. + (get_level_88_domain): Likewise. + (get_class_condition_string): Likewise. + (parser_call_targets_dump): Likewise. + (parser_compile_ecs): Likewise. + (initialize_variable_internal): Likewise. + (move_tree): Likewise. + (combined_name): Likewise. + (assembler_label): Likewise. + (find_procedure): Likewise. + (parser_perform): Likewise. + (parser_perform_times): Likewise. + (internal_perform_through): Likewise. + (internal_perform_through_times): Likewise. + (psa_FldLiteralN): Likewise. + (psa_FldBlob): Likewise. + (parser_accept): Likewise. + (parser_accept_exception): Likewise. + (parser_accept_exception_end): Likewise. + (parser_accept_command_line): Likewise. + (parser_accept_envar): Likewise. + (parser_display_internal): Likewise. + (parser_display): Likewise. + (parser_assign): Likewise. + (parser_initialize_table): Likewise. + (parser_arith_error): Likewise. + (parser_arith_error_end): Likewise. + (parser_division): Likewise. + (label_fetch): Likewise. + (parser_label_label): Likewise. + (parser_label_goto): Likewise. + (parser_perform_start): Likewise. + (parser_perform_conditional): Likewise. + (parser_perform_conditional_end): Likewise. + (parser_perform_until): Likewise. + (parser_file_delete): Likewise. + (parser_intrinsic_subst): Likewise. + (create_lsearch_address_pairs): Likewise. + (parser_bsearch_start): Likewise. + (is_ascending_key): Likewise. + (parser_sort): Likewise. + (parser_file_sort): Likewise. + (parser_return_start): Likewise. + (parser_file_merge): Likewise. + (parser_string_overflow): Likewise. + (parser_unstring): Likewise. + (parser_string): Likewise. + (parser_call_exception): Likewise. + (create_and_call): Likewise. + (mh_identical): Likewise. + (move_helper): Likewise. + (binary_initial_from_float128): Likewise. + (initial_from_initial): Likewise. + (psa_FldLiteralA): Likewise. + (parser_local_add): Likewise. + (parser_symbol_add): Likewise. + * genapi.h (parser_display): Likewise. + * gengen.cc (gg_call_expr): Explict check for NULL_TREE. + (gg_call): Likewise. + * show_parse.h (SHOW_PARSE_LABEL_OK): Likewise. + (TRACE1_FIELD_VALUE): Likewise. + (CHECK_FIELD): Likewise. + (CHECK_FIELD2): Likewise. + (CHECK_LABEL): Likewise. + * util.cc (cbl_internal_error): Apply [[noreturn]] attribute. + * util.h (cbl_internal_error): Likewise. + +2025-07-11 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + PR cobol/120621 + * lexio.cc (parse_replace_pairs): Cast mfile.lineno() to fmt_size_t. + * parse.y (intrinsic): Print ptrdiff_t using %ld, cast arg to long. + * scan_ante.h (numstr_of): Print nx using %ld, cast arg to long. + * util.cc (cbl_field_t::report_invalid_initial_value): Print + ptrdiff_t using %ld, cast arg to long. + +2025-07-10 James K. Lowden <jklowden@cobolworx.com> + + PR cobol/120765 + * cdf.y: Extend grammar for new CDF syntax, relocate dictionary. + * cdfval.h (cdf_dictionary): Use new CDF dictionary. + * dts.h: Remove useless assignment, note incorrect behavior. + * except.cc: Remove obsolete EC state. + * gcobol.1: Document CDF in its own section. + * genapi.cc (parser_statement_begin): Use new EC state function. + (parser_file_merge): Same. + (parser_check_fatal_exception): Same. + * genutil.cc (get_and_check_refstart_and_reflen): Same. + (get_depending_on_value_from_odo): Same. + (get_data_offset): Same. + (process_this_exception): Same. + * lexio.cc (check_push_pop_directive): New function. + (check_source_format_directive): Restrict regex search to 1 line. + (cdftext::free_form_reference_format): Use new function. + * parse.y: Define new CDF tokens, use new CDF state. + * parse_ante.h (cdf_tokens): Use new CDF state. + (redefined_token): Same. + (class prog_descr_t): Remove obsolete CDF state. + (class program_stack_t): Same. + (current_call_convention): Same. + * scan.l: Recognize new CDF tokens. + * scan_post.h (is_cdf_token): Same. + * symbols.h (cdf_current_tokens): Change current_call_convention to return void. + * token_names.h: Regenerate. + * udf/stored-char-length.cbl: Use new PUSH/POP CDF functionality. + * util.cc (class cdf_directives_t): Define cdf_directives_t. + (current_call_convention): Same. + (cdf_current_tokens): Same. + (cdf_dictionary): Same. + (cdf_enabled_exceptions): Same. + (cdf_push): Same. + (cdf_push_call_convention): Same. + (cdf_push_current_tokens): Same. + (cdf_push_dictionary): Same. + (cdf_push_enabled_exceptions): Same. + (cdf_push_source_format): Same. + (cdf_pop): Same. + (cdf_pop_call_convention): Same. + (cdf_pop_current_tokens): Same. + (cdf_pop_dictionary): Same. + (cdf_pop_enabled_exceptions): Same. + (cdf_pop_source_format): Same. + * util.h (cdf_push): Declare cdf_directives_t. + (cdf_push_call_convention): Same. + (cdf_push_current_tokens): Same. + (cdf_push_dictionary): Same. + (cdf_push_enabled_exceptions): Same. + (cdf_push_source_format): Same. + (cdf_pop): Same. + (cdf_pop_call_convention): Same. + (cdf_pop_current_tokens): Same. + (cdf_pop_dictionary): Same. + (cdf_pop_source_format): Same. + (cdf_pop_enabled_exceptions): Same. + +2025-07-09 Robert Dubner <rdubner@symas.com> + James K. Lowden <jklowden@cobolworx.com> + + PR cobol/120765 + PR cobol/119337 + PR cobol/120794 + * Make-lang.in: Take control of the .cc.o rule. + * cbldiag.h (error_msg_direct): New declaration. + (gcc_location_dump): Forward declaration. + (location_dump): Use gcc_location_dump. + * cdf.y: Change some tokens. + * gcobc: Change dialect handling. + * genapi.cc (parser_call_targets_dump): Temporarily remove from service. + (parser_compile_dcls): Combine temporary arrays. + (get_binary_value_from_float): Apply const to one parameter. + (depending_on_value): Localize a boolean variable. + (normal_normal_compare): Likewise. + (cobol_compare): Eliminate cppcheck warning. + (combined_name): Apply const to an input parameter. + (parser_perform): Apply const to a variable. + (parser_accept): Improve handling of special_name_t parameter and + the exception conditions. + (parser_display): Improve handling of speciat_name_t parameter; use the + os_filename[] string when appropriate. + (program_end_stuff): Rename shadowing variable. + (parser_division): Consolidate temporary char[] arrays. + (parser_file_start): Apply const to a parameter. + (inspect_replacing): Likewise. + (parser_program_hierarchy): Rename shadowing variable. + (mh_identical): Apply const to parameters. + (float_type_of): Likewise. + (picky_memcpy): Likewise. + (mh_numeric_display): Likewise. + (mh_little_endian): Likewise. + (mh_source_is_group): Apply static to a variable it. + (move_helper): Quiet a cppcheck warning. + * genapi.h (parser_accept): Add exceptions to declaration. + (parser_accept_under_discussion): Add declaration. + (parser_display): Change to std::vector; add exceptions to declaration. + * lexio.cc (cdf_source_format): Improve source code location handling. + (source_format_t::infer): Likewise. + (is_fixed_format): Likewise. + (is_reference_format): Likewise. + (left_margin): Likewise. + (right_margin): Likewise. + (cobol_set_indicator_column): Likewise. + (include_debug): Likewise. + (continues_at): Likewise. + (indicated): Likewise. + (check_source_format_directive): Likewise. + (cdftext::free_form_reference_format): Likewise. + * parse.y: Tokens; program and function names; DISPLAY and ACCEPT + handling. + * parse_ante.h (class tokenset_t): Removed. + (class current_tokens_t): Removed. + (field_of): Removed. + * scan.l: Token handling. + * scan_ante.h (level_found): Comment. + * scan_post.h (start_condition_str): Remove cast author_state:. + * symbols.cc (symbols_update): Change error message. + (symbol_table_init): Correct and reorder entries. + (symbol_unresolved_file_key): New function definition. + (cbl_file_key_t::deforward): Change error message. + * symbols.h (symbol_unresolved_file_key): New declaration. + (keyword_tok): New function. + (redefined_token): New function. + (class current_tokens_t): New class. + * symfind.cc (symbol_match): Revise error message. + * token_names.h: Reorder and change numbers in comments. + * util.cc (class cdf_directives_t): New class. + (cobol_set_indicator_column): New function. + (cdf_source_format): New function. + (gcc_location_set_impl): Improve column handling in token_location. + (gcc_location_dump): New function. + (class temp_loc_t): Modify constructor. + (error_msg_direct): New function. + * util.h (class source_format_t): New class. + +2025-07-01 James K. Lowden <jklowden@cobolworx.com> + + * Make-lang.in: Use && instead of semicolon between commands. + +2025-07-01 Robert Dubner <rdubner@symas.com> + + * parse.y: printf() of size_t is %zu, not %ld. + +2025-06-30 James K. Lowden <jklowden@cobolworx.com> + + PR cobol/120772 + PR cobol/120779 + PR cobol/120790 + PR cobol/120791 + PR cobol/120794 + * gcobc: Supply -fPIC for shared objects. + * genapi.cc (linemap_add): Delete empty macro. + (parser_enter_file): Do not call linemap_add. + (parser_leave_file): Same. + * gengen.cc (location_from_lineno): Remove function. + * lexio.cc (parse_replacing_term): Allow empty term. + (cdftext::process_file): Always append to output. + (cdftext::segment_line): Output #line directives. + * lexio.h (struct span_t): Count lines in span. + * parse.y: Revamp REPOSITORY, and minor syntax extensions. + * parse_ante.h (input_file_status_notify): Update linemap filename before location. + (intrinsic_token_of): Declare. + (parser_move_carefully): Support MOVE pointer. + * parse_util.h (intrinsic_token_of): New function. + * scan.l: New EOF logic, accept NOT=, own yylloc and yylineno. + * scan_ante.h (class enter_leave_t): Do not store newline count. + (cdf_location_set): Remove declaration. + (ydfltype_of): New function. + (update_location): Accept location parameter. + (reset_location): New function. + (YY_USER_ACTION): Use update_location(). + (YY_USER_INIT): Update CDF location. + (verify_ws): New function. + (wait_for_the_child): Removed. + * symbols.h (cobol_fileline_set): return line number. + * util.cc (valid_move): Use range-based for loop. + (struct input_file_t): Remove line_map pointer. + (class unique_stack): New peek() member function. + (cobol_lineno_save): Rename to overload cobol_lineno(). + (cobol_lineno): Replaces cobol_lineno_save(). + (cobol_filename): Return void. + (location_from_lineno): New function used by genapi.cc. + (cdf_location_set): Remove. + (matched_length): No change. + (cobol_fileline_set): Return line number. + (fisspace): Remove extra semicolon. + (fisprint): Same. + * util.h (cobol_filename_restore): Return void. + (cobol_lineno_save): Remove declaration. + (cobol_lineno): Declare. + +2025-06-29 Robert Dubner <rdubner@symas.com> + + * Make-lang.in: Incorporate gcobol.clean. + * except.cc (cbl_enabled_exceptions_t::dump): Update debug message. + * genapi.cc (gg_attribute_bit_get): Formatting. + (file_static_variable): Formatting. + (trace1_init): Formatting. + (build_main_that_calls_something): Normalize function_decl use. + (parser_call_target): Likewise. + (set_call_convention): Likewise. + (parser_call_target_convention): Likewise. + (parser_call_targets_dump): Likewise. + (function_handle_from_name): Likewise. + (function_pointer_from_name): Likewise. + (parser_initialize_programs): Likewise. + (parser_statement_begin): Formatting. + (parser_leave_file): Use function_decl FIFO. + (enter_program_common): Normalize function_decl use. + (parser_enter_program): Normalize function_decl use. + (tree_type_from_field_type): Normalize function_decl use. + (is_valuable): Comment. + (pe_stuff): Change name to program_end_stuff. + (program_end_stuff): Likewise. + (parser_exit): Likewise. + (parser_division): Normalize function_decl use. + (create_and_call): Normalize function_decl use. + (parser_call): Normalize function_decl use. + (parser_set_pointers): Normalize function_decl use. + (parser_program_hierarchy): Normalize function_decl use. + (psa_FldLiteralA): Defeat attempt to re-use literals. (Fails on some aarch64). + (parser_symbol_add): Error message formatting. + * genapi.h: Formatting. + * gengen.cc (struct cbl_translation_unit_t): Add function_decl FIFO. + (show_type): Rename to gg_show_type. + (gg_show_type): Correct an error message. + (gg_assign): Formatting; change error handling. + (gg_modify_function_type): Normalize function_decl use. + (gg_define_function_with_no_parameters): Fold into gg_defint_function(). + (function_decl_key): Normalize function_decl use. + (gg_peek_fn_decl): Normalize function_decl use. + (gg_build_fn_decl): Normalize function_decl use. + (gg_define_function): Normalize function_decl use. + (gg_tack_on_function_parameters): Remove. + (gg_finalize_function): Normalize function_decl use. + (gg_leaving_the_source_code_file): Normalize function_decl use. + (gg_call_expr_list): Normalize function_decl use. + (gg_trans_unit_var_decl): Normalize function_decl use. + (gg_insert_into_assemblerf): New function; formatting. + * gengen.h (struct gg_function_t): Eliminate "is_truly_nested" flag. + (gg_assign): Incorporate return value. + (gg_define_function): Normalize function_decl use. + (gg_define_function_with_no_parameters): Eliminate. + (gg_build_fn_decl): Normalize function_decl use. + (gg_peek_fn_decl): Normalize function_decl use. + (gg_modify_function_type): Normalize function_decl use. + (gg_call_expr_list): Normalize function_decl use. + (gg_get_function_decl): Normalize function_decl use. + (location_from_lineno): Prefix with "extern". + (gg_open): Likewise. + (gg_close): Likewise. + (gg_get_indirect_reference): Likewise. + (gg_insert_into_assembler): Likewise. + (gg_insert_into_assemblerf): Likewise. + (gg_show_type): New declaration. + (gg_leaving_the_source_code_file): New declaration. + * parse.y: Format debugging message. + * parse_ante.h: Normalize function_decl use. + +2025-06-20 James K. Lowden <jklowden@cobolworx.com> + + PR cobol/120621 + * genapi.cc (parser_compile_ecs): Cast argument to unsigned long. + (parser_compile_dcls): Same. + (parser_division): RAII. + (inspect_tally): Cast argument to unsigned long. + * lexio.cc (cdftext::lex_open): Cast pid_t to long. + * parse.y: hard-code values for old versions of Bison, and message format. + * scan_ante.h (wait_for_the_child): Cast pid_t to long. + +2025-06-18 James K. Lowden <jklowden@cobolworx.com> + + PR cobol/120621 + * cbldiag.h (yyerror): Add diagnostic attributes. + (yywarn): Same. + (error_msg): Same. + (yyerrorvl): Same. + (cbl_unimplementedw): Same. + (cbl_unimplemented): Same. + (cbl_unimplemented_at): Same. + * cdf-copy.cc (copybook_elem_t::open_file): Supply string argument. + * cdf.y: Use %<%>. + * cobol-system.h (if): Check GCC_VERSION. + (ATTRIBUTE_GCOBOL_DIAG): Define. + * except.cc (cbl_enabled_exception_t::dump): Remove extra %s. + * genapi.cc (get_class_condition_string): Use acceptable message. + (get_bytes_needed): Same. + (move_tree): Same. + (get_string_from): Same. + (internal_perform_through): Same. + (tree_type_from_field_type): Same. + (is_valuable): Same. + (parser_logop): Same. + (parser_relop): Same. + (parser_relop_long): Same. + (parser_if): Same. + (parser_setop): Same. + (parser_perform_conditional): Same. + (parser_file_add): Same. + (parser_file_open): Same. + (parser_file_close): Same. + (parser_file_read): Same. + (parser_file_write): Same. + (inspect_replacing): Same. + (parser_sort): Same. + (parser_file_sort): Same. + (parser_file_merge): Same. + (create_and_call): Same. + (parser_bitop): Same. + (parser_bitwise_op): Same. + (hijack_for_development): Same. + (mh_source_is_literalN): Same. + (mh_dest_is_float): Same. + (parser_symbol_add): Same. + * gengen.cc (show_type): Use acceptable message. + (gg_find_field_in_struct): Same. + (gg_declare_variable): Same. + (gg_printf): Same. + (gg_fprintf): Same. + (gg_tack_on_function_parameters): Same. + (gg_define_function): Same. + (gg_get_function_decl): Same. + (gg_finalize_function): Same. + (gg_call_expr): Same. + (gg_call): Same. + (gg_insert_into_assembler): Define new function. + (gg_insert_into_assemblerf): Use gg_insert_into_assembler(). + * gengen.h (gg_insert_into_assembler): Simpler function declaration. + (gg_insert_into_assemblerf): Declare new function. + * genmath.cc (parser_op): Use acceptable message. + * genutil.cc (get_binary_value): Use acceptable message. + * lexio.cc (parse_replacing_pair): Correct diagnostic arguments. + (preprocess_filter_add): Same. + (cdftext::open_input): Same. + * parse.y: Use acceptable messages. + * parse_ante.h (struct evaluate_elem_t): Use %<%>. + (is_callable): Same. + * parse_util.h (intrinsic_invalid_parameter): Use %qs. + * scan.l: Use dialect_error(). + * scan_ante.h (numstr_of): Use %qs. + (scanner_token): Quote COBOL tokens in messages. + (scanner_parsing): Correct diagnostic message. + (scanner_parsing_toggle): Quote COBOL tokens in messages. + (scanner_parsing_pop): Same. + (typed_name): Use %qs. + * scan_post.h (prelex): Quote COBOL tokens in message. + * show_parse.h (CHECK_FIELD): Use acceptable message format. + (CHECK_LABEL): Same. + * symbols.cc (symbol_field_same_as): Remove extra spaces. + (cbl_alphabet_t::assign): Use %<%>. + (cbl_field_t::internalize): Quote library name in message. + * symbols.h (struct os_locale_t): Constify codeset. + (class temporaries_t): Add copy constructor. + (struct cbl_alphabet_t): Use acceptable message. + * util.cc (symbol_type_str): Use cbl_internal_error. + (cbl_field_type_str): Same. + (is_elementary): Same. + (cbl_field_t::report_invalid_initial_value): Use %qs. + (class unique_stack): Avoid %m. + (ydferror): Declare function with attributes. + (error_msg): Same. + (cobol_fileline_set): Use %<%>. + (os_locale_t): Remove use of xstrdup. + (cobol_parse_files): Quote C names in message. + (dialect_error): Use %<%>. + * util.h (cbl_message): Add attributes. + (cbl_internal_error): Same. + (cbl_err): Same. + (cbl_errx): Same. + +2025-06-16 James K. Lowden <jklowden@cobolworx.com> + + PR cobol/120621 + * Make-lang.in: Use STRICT_WARN. + * cbldiag.h (location_dump): suppress shadowVariable. + * cdf-copy.cc (esc): Fix shadowVariable. + (copybook_elem_t::open_file): Do not use %m. + * cdf.y: suppress invalidPrintfArgType for target format. + * cdfval.h (struct cdfval_t): Suppress noExplicitConstructor. + * cobol1.cc (cobol_name_mangler): Use C++ cast. + * copybook.h (class copybook_elem_t): Same. + * dts.h: Fixes and suppressions due to cppcheck. + * except.cc (cbl_enabled_exceptions_t::status): Suppress useStlAlgorithm. + (cbl_enabled_exceptions_t::turn_on_off): Const parameter. + (class choose_declarative): Removed. + * genapi.cc (struct called_tree_t): Explicit constructor. + (parser_compile_ecs): Cast to void * for %p. + (parser_compile_dcls): Same. + (parser_statement_begin): Same. + (initialize_variable_internal): Use std::vector for subscripts. + (parser_initialize): Constification. + (get_string_from): Same. + (combined_name): Same. + (parser_perform): Same. + (psa_FldLiteralN): Same. + (is_figconst): Const parameter. + (is_figconst_t): Same. + (parser_exit): Same. + (parser_division): Const pointer. + (parser_perform_conditional): Whitespace. + (parser_set_conditional88): Const parameter. + (inspect_tally): Use std::vector. + (inspect_replacing): Same. + (parser_inspect): Same. + (parser_intrinsic_subst): Use std::vector (constuct elements). + (parser_intrinsic_call_1): Use std::vector for subscripts. + (is_ascending_key): Const pointer. + (parser_sort): Use std::vector. + (parser_file_sort): Same. + (parser_file_merge): Same. + (parser_unstring): Same. + (parser_string): Same. + (parser_call): Const pointer. + (parser_program_hierarchy): Use std::vector. + (conditional_abs): Const paraemeter. + (float_type_of): Same. + (initial_from_initial): Set value, quoted or not. + (parser_symbol_add): Remove redundant nested test. + * genapi.h (parser_add): Const parameters. + (parser_subtract): Same. + (parser_multiply): Same. + (parser_divide): Same. + (parser_perform): Same. + (parser_exit): Same. + (parser_initialize): Same. + (parser_set_conditional88): Same. + (parser_sort): Same. + (parser_file_sort): Same. + (parser_file_merge): Same. + (parser_string): Same. + (is_ascending_key): Same. + * genmath.cc (arithmetic_operation): Use std::vector. + (is_somebody_float): Const parameter. + (all_results_binary): Const parameter. + (fast_multiply): Remove redundant nested test. + (parser_add): Const parameter. + (parser_multiply): Remove redundant nested test. + (parser_divide): Const parameter. + (parser_subtract): Same. + * genutil.cc (get_depending_on_value): Use std::vector. + (get_data_offset): Same. + (tree_type_from_field): Const parameter. + (refer_has_depends): Const pointers. + (get_literal_string): RAII. + (refer_is_clean): Use std::vector. + (get_time_nanoseconds): Newline at EOF. + * genutil.h (tree_type_from_field): Remove declaration. + * inspect.h (struct cbx_inspect_qual_t): Use std::vector. + (struct cbl_inspect_qual_t): Same. + (struct cbx_inspect_match_t): Same. + (class cbl_inspect_match_t): Same. + (struct cbx_inspect_replace_t): Same. + (struct cbl_inspect_replace_t): Same. + (struct cbx_inspect_oper_t): Same. + (struct cbl_inspect_oper_t): Same. + (struct cbx_inspect_t): Same. + (struct cbl_inspect_t): Same. + (parser_inspect): Same. + * lexio.cc (indicated): Const pointer. + (remove_inline_comment): Scope reduction. + (maybe_add_space): Const pointer. + (recognize_replacements): C++ cast. + (check_source_format_directive): Same. + (struct replacing_term_t): Explicit constructor. + (parse_replace_pairs): Const reference. + (location_in): Const reference. + (parse_copy_directive): C++ cast. + (parse_replace_last_off): Const parameter. + (parse_replace_text): Const reference. + (parse_replace_directive): C++ cast. + (cdftext::lex_open): Const reference. + (cdftext::open_output): Scope reduction. + (cdftext::free_form_reference_format): Remove unused variable. + (cdftext::process_file): Simplify. + * lexio.h (struct bytespan_t): Use nullptr. + (struct filespan_t): Initialize icol in constructor. + (struct span_t): Suppress confused operatorEqRetRefThis. + (struct replace_t): Eliminate single-value constructor. + * parse.y: Many const cppcheck reports, and portable bit-shift. + * parse_ante.h (reject_refmod): Const parameter. + (require_pointer): Same. + (require_integer): Same. + (struct evaluate_elem_t): Explicit constructor. + (struct arith_t): Use std::vector. + (class eval_subject_t): Const parameter. + (dump_inspect_match): Declare. + (struct perform_t): Explicit constructor. + (list_add): Const parameter. + (class tokenset_t): Avoid negative array index. + (struct file_list_t): Explicit constructor. + (struct field_list_t): Same. + (struct refer_list_t): Same. + (struct refer_marked_list_t): Const parameter. + (struct refer_collection_t): Explicit constructor. + (struct ast_inspect_oper_t): Remove class. + (ast_inspect_oper_t): Same. + (struct ast_inspect_t): Same. + (struct ast_inspect_list_t): Same. + (ast_inspect): Add location. + (struct elem_list_t): Explicit constructor. + (struct unstring_tgt_t): Same. + (struct unstring_tgt_list_t): Same. + (struct unstring_into_t): Same. + (struct ffi_args_t): Same. + (struct file_sort_io_t): Same. + (merge_t): Same. + (struct vargs_t): Same. + (class prog_descr_t): Eliminate single-value constructor. + (class program_stack_t): Suppress useStlAlgorithm. + (struct rel_part_t): Eliminate single-value constructor. + (class log_expr_t): Explicit constructor. + (add_debugging_declarative): Rename local variable. + (intrinsic_call_2): Const parameter. + (invalid_key): Use std::find_if. + (parser_add2): Const parameter. + (parser_subtract2): Same. + (stringify): Same. + (unstringify): Same. + (anybody_redefines): Same. + (ast_call): Same. + * parse_util.h (class cname_cmp): Explicit constructor. + (intrinsic_inconsistent_parameter): Same. + * scan_ante.h (struct cdf_status_t): Eliminate single-value constructor. + (class enter_leave_t): Explicit constructor. + (update_location): Const pointer, explicit constructor. + (symbol_function_token): Const pointer. + (typed_name): Same. + * scan_post.h (datetime_format_of): Scope reduction. + * show_parse.h (class ANALYZE): Use std::vector, explicit consstructor. + * symbols.cc (symbol_table_extend): Scope reduction. + (cbl_ffi_arg_t::cbl_ffi_arg_t): Define default constructor. + (end_of_group): Const pointer. + (symbol_find_odo): Const parameter. + (rename_not_ok): Same. + (field_str): Use %u instead of %d. + (struct capacity_of): Const pointer. + (symbols_update): Same. + (symbol_field_parent_set): Same. + (symbol_file_add): Same. + (symbol_typedef_add): Same. + (symbol_field_add): Use new operator=(). + (symbol_field): Suppress CastIntegerToAddressAtReturn. + (symbol_register): Same. + (symbol_file): Suppress knownConditionTrueFalse. + (next_program): Const parameter. + (symbol_file_record): Same. + (class is_section): Explicit constructor. + (cbl_file_t::no_key): Remove. + (cbl_prog_hier_t::cbl_prog_hier_t): Use std::vector. + (symbol_label_add): Assert pointer is not NULL. + (symbol_label_section_exists): Const reference in lambda. + (expand_picture): Use C++ cast. + (symbol_program_callables): Const pointer. + (symbol_currency_add): Suppress nullPointerRedundantCheck. + (cbl_key_t): Use std::vector. + (cbl_occurs_t::field_add): Const parameter. + (cbl_occurs_t::index_add): Explicit constructor. + (class is_field_at): Same. + (cbl_file_key_t::deforward): Scope reduction. + (cbl_file_t::keys_str): Use allocated memory only. + (file_status_status_of): Const pointer. + (is_register_field): Const parameter. + * symbols.h (struct cbl_field_data_t): Eliminate single-value constructor. + (struct cbl_occurs_bounds_t): Same. + (struct cbl_refer_t): Use std::vector. + (valid_move): Const parameter. + (is_register_field): Same. + (struct cbl_key_t): Use std::vector. + (struct cbl_substitute_t): Eliminate single-value constructor. + (refer_of): Return const reference + (struct cbl_ffi_arg_t): Eliminate single-value constructor. + (class temporaries_t): Same. + (struct cbl_file_key_t): Define default constructor. + (struct cbl_file_lock_t): Define copy constructor and operator=(). + (struct cbl_file_t): Complete default constructor. + (struct symbol_elem_t): Explicit constructor. + (symbol_elem_of): Suppress cstyleCast. + (symbol_redefines): Const parameter. + (struct cbl_field_t): Same. + (cbl_section_of): Test for NULL pointer. + (cbl_field_of): Same. + (cbl_label_of): Same. + (cbl_special_name_of): Same. + (cbl_alphabet_of): Same. + (cbl_file_of): Same. + (is_figconst): Delete extra "struct" keyword. + (is_figconst_low): Same. + (is_figconst_zero): Same. + (is_figconst_space): Same. + (is_figconst_quote): Same. + (is_figconst_high): Same. + (is_space_value): Same. + (is_quoted): Same. + (symbol_index): Const parameter. + (struct cbl_prog_hier_t): Suppress noExplicitConstructor. + (struct cbl_perform_vary_t): Eliminate single-value constructor. + (is_signable): Const parameter. + (is_temporary): Same. + (rename_not_ok): Same. + (field_at): Test for NULL pointer. + (class procref_base_t): Eliminate single-value constructor. + * symfind.cc (is_data_field): Const pointer. + (finalize_symbol_map2): Same. + (class in_scope): Same. + (symbol_match2): Same. + * token_names.h: Suppress useInitializationList. + * util.cc (normalize_picture): Whitespace and remove extra "continue". + (redefine_field): Const pointer. + (cbl_field_t::report_invalid_initial_value): Same. + (literal_subscript_oob): Rename shadow variable. + (cbl_refer_t::subscripts_set): Use std::vector. + (cbl_refer_t::str): Same. + (cbl_refer_t::deref_str): Same. + (locally_unique): Use explicit constructor. + (ambiguous_reference): Same. + (class unique_stack): Use const reference. + (cobol_filename): Const pointer. + (verify_format): Scope reduction. + (class temp_loc_t): Do not derive from YYLTYPE. + (cobol_parse_files): Const pointer. + * util.h (as_voidp): Define convenient converter. + +2025-06-10 James K. Lowden <jklowden@cobolworx.com> + + * Make-lang.in: cobol.clean does not remove libgcobol files. + * cdf.y: Suppress 1 cppcheck false positive. + * cdfval.h (scanner_parsing): Partial via cppcheck for PR119324. + * gcobol.1: Fix groff errors. + * gcobolspec.cc (append_arg): Const parameter. + * parse_ante.h (intrinsic_call_2): Avoid NULL dereference. + +2025-06-06 Robert Dubner <rdubner@symas.com> + James K. Lowden <jklowden@cobolworx.com> + + PR cobol/120328 + PR cobol/119695 + * Make-lang.in: Success with non-English locale. + * cbldiag.h (cbl_unimplemented_at): Comment: + * cdf-copy.cc (copybook_elem_t::open_file): Indentation. + * cdf.y: YYABORT on certain errors. + * cdfval.h (cdf_value): Const parameter. + * copybook.h (class copybook_elem_t): Initialization. + (class uppername_t): Explicit constructor. + * except.cc (ec_type_descr): Remove %04s. + (cbl_enabled_exceptions_t::dump): Remove %zu. + * exceptg.h (class exception_turn_t): Explicit constructor. + * genapi.cc (parser_perform_conditional): Remove %zu. + (set_exception_environment): Formatting. + (parser_statement_begin): Exception overhead. + (parser_perform_conditional): Formatting: + (parser_perform_conditional_end): Eliminate size_t. + (parser_check_fatal_exception): Exception overhead. + (parser_perform_conditional_end): Remove %zu. + * inspect.h (struct cbx_inspect_match_t): Const reference. + (struct cbx_inspect_t): Const parameter. + * lexio.cc (cdftext::process_file): Remove %zu. + * lexio.h (struct YYLTYPE): Remove unneeded struct. + (YYLTYPE_IS_DECLARED): Likewise. + (YYLTYPE_IS_TRIVIAL): Likewise. + * parse.y: Comment; change DOT. + * scan.l: Scan function names without swallowing whitespace. + * scan_ante.h (scanner_parsing): Remove %zu. + (scanner_parsing_pop): Remove %zu. + (binary_integer_usage): Remove %zu. + * scan_post.h (prelex): Correct post-CDF resumption. + (yylex): Clearer message. + * symbols.cc (symbol_table_extend): Explicit constructor. + (elementize): Const parameter. + (is_variable_length): Correct always-false. + (symbols_update): Remove unnecessary shadow variable. + (struct symbol_elem_t): Const parameter. + (symbol_alphabet_add): Const parameter. + (new_literal_add): Initialization. + * symbols.h (class cbl_domain_elem_t): Correct assignment. + (struct cbl_span_t): Improve constructor. + (struct cbl_refer_t): Initialization. + (struct cbl_alphabet_t): Rename shadow variable. + (struct cbl_file_key_t): Remove unused constructor. + (struct symbol_elem_t): Initialization. + (struct cbl_until_addresses_t): Use unsigned int, for messages. + (struct cbl_prog_hier_t): Initialization. + (struct cbl_perform_tgt_t): Repair constructor. + (struct cbl_label_t): Const parameter. + (symbol_typedef_add): Const parameter. + (symbol_field_add): Explicit constructor. + (symbol_label_add): Explicit constructor. + (symbol_program_add): Remove C-style "struct" use. + (symbol_special_add): Remove C-style "struct" use. + (symbol_alphabet_add): Const parameter. + (symbol_file_add): Remove C-style "struct" use. + (symbol_section_add): Remove C-style "struct" use. + * symfind.cc: Const parameter. + * util.cc (gb4): New function. + * util.h (gb4): New function. + * TODO: New file. + +2025-06-05 Robert Dubner <rdubner@symas.com> + + PR cobol/119975 + * genapi.cc (parser_intrinsic_call_0): Use get_time_nanoseconds(). + * genutil.cc (get_time_64): Rename to get_time_nanoseconds(). + (get_time_nanoseconds): Likewise. + * genutil.h (get_time_64): Likewise. + (get_time_nanoseconds): Likewise. + * util.cc (class cbl_timespec): Timing routine uses + get_time_nanoseconds(). + (operator-): Likewise. + (parse_file): Likewise. + +2025-06-02 Robert Dubner <rdubner@symas.com> + + PR cobol/119975 + * genapi.cc (parser_intrinsic_call_0): Use get_time_64() function. + * genutil.cc (get_time_64): Definition created. + * genutil.h (get_time_64): Declaration created. + +2025-06-01 Robert Dubner <rdubner@symas.com> + + PR cobol/119524 + * gengen.cc (gg_printf): Use the new __gg__fprintf_stderr() function + instead of generating a call to fprintf(). + +2025-05-20 Robert Dubner <rdubner@symas.com> + James K. Lowden <jklowden@cobolworx.com> + + PR cobol/119770 + PR cobol/119772 + PR cobol/119790 + PR cobol/119771 + PR cobol/119810 + PR cobol/119335 + PR cobol/119632 + * cdf-copy.cc (GLOB_BRACE): Eliminate <glob.h>. + * cdfval.h (_CDF_VAL_H_): Switch to C++ headers. + * copybook.h (class copybook_elem_t): Eliminate <glob.h>. + (class copybook_t): Likewise. + * gcobc: Numerous changes to improve utility. + * gcobol.1: Correct names in the list of functions. + * genapi.cc (compare_binary_binary): Use has_attr() function. + * lexio.cc (cdftext::lex_open): Typo; filename logic. + (cdftext::process_file): Filename logic. + * parse.y: Numerous parsing changes. + * parse_ante.h (new_alphanumeric): C++ includes; changes to temporaries. + (new_tempnumeric): Likewise. + (new_tempnumeric_float): Likewise. + (set_real_from_capacity): Created. + * scan.l: Use yy_pop_state(). + * scan_ante.h (typed_name): Find figconst from data.initial. + * symbols.cc (symbol_valid_udf_args): Eliminate. + (symbols_update): figconst processing. + (new_temporary_impl): For functions, set .initial to function name. + (temporaries_t::acquire): Likewise. + (new_alphanumeric): Likewise. + (new_temporary): Likewise. + * symbols.h (_SYMBOLS_H_): Use C++ includes. + (cbl_figconst_tok): Change handling of figconst. + (cbl_figconst_field_of): Change handling of figconst. + (symbol_valid_udf_args): Eliminate. + * symfind.cc (symbol_match2): Change declaration. + (symbol_match): Change declaration. + +2025-05-18 Mark Wielaard <mark@klomp.org> + + * lang.opt.urls: Regenerated. + +2025-05-16 Robert Dubner <rdubner@symas.com> + + * cobol1.cc (cobol_langhook_handle_option): Eliminate OPT_M. + * except.cc (cbl_enabled_exception_t::dump): Formatting. + (symbol_declaratives_add): Remove. + (declarative_runtime_match): Change to no-blob processing. + * exceptg.h (declarative_runtime_match): Change declaration. + (symbol_declaratives_add): Remove declaration. + * gcobc: Dialect handling. + * genapi.cc (parser_compile_ecs): Formatting; add SHOW_IF_PARSE. + (parser_compile_dcls): Likewise. + (parser_statement_begin): Avoid unnecessary store_location_stuff() call. + (gg_get_depending_on_value): Streamline get_depending_on_value_from_odo(). + (depending_on_value): Likewise. + (parser_display_field): Formatting. + (parser_display): Handle case ENV_NAME_e. + (parser_file_open): Avoid unnecessary store_location_stuff. + (parser_file_close): Likewise. + (parser_file_read): Likewise. + (parser_file_write): Likewise. + (parser_file_delete): Likewise. + (parser_file_rewrite): Likewise. + (parser_file_start): Likewise. + (parser_intrinsic_subst): Streamline get_depending_on_value_from_odo(). + (parser_intrinsic_call_1): Likewise. + (parser_lsearch_start): Likewise. + (parser_bsearch_start): Likewise. + (parser_sort): Likewise. + (store_location_stuff): Avoid unnecessary assignments. + (parser_pop_exception): Formatting. + * genmath.cc (parser_add): Avoid var_decl_default_compute_error assignment + when doing fast_add(). + (parser_subtract): Likewise. + * genutil.cc (REFER): Macro for analyzing code generation. + (get_integer_value): Use data_decl_node for integer value from FldLiteralN. + (get_data_offset): Streamline exception code processing. + (get_and_check_refstart_and_reflen): Likewise. + (get_depending_on_value_from_odo): Likewise. + (get_depending_on_value): Likewise. + (refer_is_clean): Formatting. + (refer_refmod_length): Streamline exception code processing. + (refer_fill_depends): Likewise. + (refer_offset): Likewise. + (refer_size_dest): Likewise. + (refer_size_source): Likewise. + * genutil.h (get_depending_on_value_from_odo): Likewise. + * lang-specs.h: Options definition. + * lang.opt: -M as in c.opt. + * lexio.h: Formatting. + * parse.y: Expand -dialect suggestions; SECTION SEGMENT messages. + * parse_ante.h (declarative_runtime_match): Dialect handling. + (labels_dump): Likewise. + (class current_tokens_t): Likewise. + (class prog_descr_t): Make program_index size_t to prevent padding bytes. + * scan.l: POP_FILE directive. + * scan_ante.h (class enter_leave_t): Better handle line number when + processing COPY statements. + * symbols.cc (symbol_elem_cmp): Eliminate SymFunction. + (symbols_dump): Likewise. + (symbol_label_section_exists): Likewise. + * symbols.h (NAME_MAX): Eliminate. (Was part of SymFunction). + (dialect_is): Improve dialect handling. + (dialect_gcc): Likewise. + (dialect_ibm): Likewise. + (dialect_gnu): Likewise. + (enum symbol_type_t): Eliminate SymFunction. + * util.cc (symbol_type_str): Likewise. + (class unique_stack): Option -M handling. + (cobol_set_pp_option): Likewise. + (parse_file): Likewise. + * util.h (cobol_set_pp_option): Likewise. + +2025-05-10 Robert Dubner <rdubner@symas.com> + + PR cobol/119337 + * 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 + * genapi.cc (function_handle_from_name): Use sizeof_pointer. + (parser_file_add): Use int_size_in_bytes(VOID_P) and + int_size_in_bytes(int). + (inspect_tally): Use int_size_in_bytes(VOID_P). + (inspect_replacing): Likewise. + (gg_array_of_field_pointers): Likewise. + (gg_array_of_file_pointers): Likewise. + (parser_set_pointers): Use sizeof_pointer. + * cobol1.cc (create_our_type_nodes_init): Use + int_size_in_bytes(SIZE_T) and int_size_in_bytes(VOID_P). + * gengen.cc (gg_array_of_size_t): Use int_size_in_bytes(SIZE_T). + (gg_array_of_bytes): Just use N, don't multiply it by + sizeof(unsigned char). + * parse.y: Include tree.h. Use int_size_in_bytes(ptr_type_node). + +2025-04-07 Iain Sandoe <iain@sandoe.co.uk> + + * symbols.cc : Remove trailing // on standard_internal. + (cbl_field_t::internalize): Print a warning if we fail to + initialise iconv. + +2025-04-07 Jakub Jelinek <jakub@redhat.com> + + * Make-lang.in (cobol/charmaps.cc, cobol/valconv.cc): Use a BRE + only sed regex. + +2025-04-07 Jakub Jelinek <jakub@redhat.com> + + PR web/119227 + * Make-lang.in (GCOBOL_HTML_FILES): New variable. + (cobol.install-html, cobol.html, cobol.srchtml): Use + $(GCOBOL_HTML_FILES) instead of gcobol.html gcobol-io.html. + (gcobol.html): Rename goal to ... + ($(build_htmldir)/gcobol/gcobol.html): ... this. Run mkinstalldirs. + (gcobol-io.html): Rename goal to ... + ($(build_htmldir)/gcobol/gcobol-io.html): ... this. Run mkinstalldirs. + +2025-04-06 Iain Sandoe <iain@sandoe.co.uk> + + PR cobol/119414 + * gcobolspec.cc (append_rdynamic, + append_allow_multiple_definition, append_fpic): Remove. + (lang_specific_driver): Remove platform-specific command + line option handling. + +2025-04-05 Iain Sandoe <iain@sandoe.co.uk> + + * gcobolspec.cc (SPEC_FILE): New. + (lang_specific_driver): Make the 'need libgcobol' flag global + so that the prelink callback can use it. Libm use is now handled + via the library spec. + (lang_specific_pre_link): Include libgcobol.spec where needed. + +2025-04-04 Bob Dubner <rdubner@symas.com> + + * cobol1.cc: Eliminate cobol_langhook_post_options. + * symbols.cc: Definition of RETURN-CODE special register sets + ::attr member to signable_e. + +2025-04-04 Bob Dubner <rdubner@symas.com> + + * cobol1.cc: (cobol_langhook_post_options): Implemented in order to set + flag_strict_aliasing to zero. + * genapi.cc: (set_user_status): Add comment. + (parser_intrinsic_subst): Expand SHOW_PARSE information. + (psa_global): Change names of return-code and upsi globals, + (psa_FldLiteralA): Set DECL_PRESERVE_P for FldLiteralA. + * gengen.cc: (show_type): Add POINTER type. + (gg_define_function_with_no_parameters): Set DECL_PRESERVE_P for COBOL- + style nested programs. (gg_array_of_bytes): Fix bad cast. + +2025-04-03 Jakub Jelinek <jakub@redhat.com> + + PR cobol/119242 + * genapi.cc (binary_initial_from_float128): Use + native_encode_wide_int. + +2025-04-02 Bob Dubner <rdubner@symas.com> + + PR cobol/119521 + * genapi.cc: (parser_division): Change comment. + (parser_symbol_add): Change intermediate_t handling. + * parse.y: Multiple changes to new_alphanumeric() calls. + * parse_ante.h: Establish named constant for date function + calls. Change declaration of new_alphanumeric() function. + * symbols.cc: (new_temporary_impl): Use named constant + for default size of temporary alphanumerics. + * symbols.h: Establish MAXIMUM_ALPHA_LENGTH constant. + +2025-04-02 Jonathan Wakely <jwakely@redhat.com> + + * symfind.cc (finalize_symbol_map2): Use std::list::remove_if + instead of std::remove_if. + +2025-04-01 Bob Dubner <rdubner@symas.com> + + * genapi.cc: (section_label): Use xasprintf() instead of sprintf(). + (paragraph_label): Likewise. (leave_procedure): Likewise. + (find_procedure): Likewise. (parser_goto): Likewise. + (parser_enter_file): Likewise. + +2025-03-28 Jakub Jelinek <jakub@redhat.com> + + * Make-lang.in (cobol/charmaps.cc, cobol/valconv.cc): Used sed -e + instead of cp and multiple sed -i commands. Always prefix libgcobol + header names in #include directives with ../../libgcobol/ rather than + something depending on $(LIB_SOURCE). + +2025-03-28 Bob Dubner <rdubner@symas.com> + + * Make-lang.in: Eliminate libgcobol.h from gcc/cobol files. + * genapi.cc: Eliminate "#include libgcobol.h". + (parser_display_internal): Change comment. + * genmath.cc: Eliminate "#include libgcobol.h". + * genutil.cc: Likewise. + (get_power_of_ten): Change comment. + * structs.cc: Eliminate cblc_int128_type_node. + * structs.h: Likewise. + * symbols.h: Receive comment from libgcobol.h + +2025-03-28 Jakub Jelinek <jakub@redhat.com> + + * Make-lang.in (cobol.srcextra): Use sed to turn + .../gcc/cobol/*.{y,l,h,cc} and cobol/*.{y,l,h,cc} in #line directives + into just *.{y,l,h,cc}. + +2025-03-28 Richard Biener <rguenther@suse.de> + + PR bootstrap/119513 + * Make-lang.in (cobol.srcextra): Use cp instead of ln, ignore + errors. + +2025-03-28 Bob Dubner <rdubner@symas.com> + + * genapi.cc: (create_and_call): cast unsigned char to int + +2025-03-28 Richard Biener <rguenther@suse.de> + + * genapi.cc (initial_from_float128): Use native_encode_real. + +2025-03-28 Iain Sandoe <iain@sandoe.co.uk> + + * cobol-system.h: Remove <cmath>. + +2025-03-26 Jonathan Wakely <jwakely@redhat.com> + + * except.cc (cbl_enabled_exceptions_t::turn_on_off): Replace + quadratic loop with a single pass. + +2025-03-26 Bob Dubner <rdubner@symas.com> + + * genapi.cc: (parser_display_internal): Adjust for E vs e exponent notation. + * parse.y: (literal_refmod_valid): Display correct value in error message. + +2025-03-26 Jakub Jelinek <jakub@redhat.com> + + PR cobol/119242 + * genutil.h (get_power_of_ten): Remove #pragma GCC diagnostic + around declaration. + * genapi.cc (psa_FldLiteralN): Change type of value from + __int128 to FIXED_WIDE_INT(128). Remove #pragma GCC diagnostic + around the declaration. Use wi::min_precision to determine + minimum unsigned precision of the value. Use wi::neg_p instead + of value < 0 tests and wi::set_bit_in_zero<FIXED_WIDE_INT(128)> + to build sign bit. Handle field->data.capacity == 16 like + 1, 2, 4 and 8, use wide_int_to_tree instead of build_int_cst. + (mh_source_is_literalN): Remove #pragma GCC diagnostic around + the definition. + (binary_initial_from_float128): Likewise. + * genutil.cc (get_power_of_ten): Remove #pragma GCC diagnostic + before the definition. + +2025-03-25 Bob Dubner <rdubner@symas.com> + Richard Biener <rguenth@suse.de> + Jakub Jelinek <jakub@redhat.com> + James K. Lowden <jklowden@cobolworx.com> + Robert Dubner <rdubher@symas.com> + + PR cobol/119241 + * cdf.y: (cdfval_base_t::operator()): Return const. + * cdfval.h: (struct cdfval_base_t): Add const cdfval_base_t& + operator(). + (struct cdfval_t): Add cdfval_t constructor. Change cdf_value + definitions. + * gcobolspec.cc (lang_specific_driver): Formatting fix. + * genapi.cc: Include fold-const.h and realmpfr.h. + (initialize_variable_internal): Use real_to_decimal instead of + strfromf128. + (get_binary_value_from_float): Use wide_int_to_tree instead of + build_int_cst_type. + (psa_FldLiteralN): Use fold_convert instead of strfromf128, + real_from_string and build_real. + (parser_display_internal): Rewritten to work on REAL_VALUE_TYPE + rather than _Float128. + (mh_source_is_literalN): Use FIXED_WIDE_INT(128) rather than + __int128, wide_int_to_tree rather than build_int_cst_type, + fold_convert rather than build_string_literal. + (real_powi10): New function. + (binary_initial_from_float128): Change type of last argument from + _Float128 to REAL_VALUE_TYPE, process it using real.cc and mpfr + APIs. + (digits_from_float128): Likewise. + (initial_from_float128): Make static. Remove value argument, add + local REAL_VALUE_TYPE value variable instead, process it using + real.cc and native_encode_expr APIs. + (parser_symbol_add): Adjust initial_from_float128 caller. + * genapi.h (initial_from_float128): Remove declaration. + * genutil.cc (get_power_of_ten): Change return type from __int128 + to FIXED_WIDE_INT(128), ditto for retval type, change type of pos + from __int128 to unsigned long long. + (scale_by_power_of_ten_N): Use wide_int_to_tree instead of + build_int_cst_type. Use FIXED_WIDE_INT(128) instead of __int128 + as power_of_ten variable type. + (copy_little_endian_into_place): Likewise. + * genutil.h (get_power_of_ten): Change return type from __int128 + to FIXED_WIDE_INT(128). + * parse.y (%union): Change type of float128 from _Float128 to + REAL_VALUE_TYPE. + (string_of): Change argument type from _Float128 to + const REAL_VALUE_TYPE &, use real_to_decimal rather than + strfromf128. Add another overload with tree argument type. + (field: cdf): Use real_zerop rather than comparison against 0.0. + (occurs_clause, const_value): Use real_to_integer. + (value78): Use build_real and real_to_integer. + (data_descr1): Use real_to_integer. + (count): Use real_to_integer, real_from_integer and real_identical + instead of direct comparison. + (value_clause): Use real_from_string3 instead of num_str2i. Use + real_identical instead of direct comparison. Use build_real. + (allocate): Use real_isneg and real_iszero instead of <= 0 comparison. + (move_tgt): Use real_to_integer, real_value_truncate, + real_from_integer and real_identical instead of comparison of casts. + (cce_expr): Use real_arithmetic and real_convert or real_value_negate + instead of direct arithmetics on _Float128. + (cce_factor): Use real_from_string3 instead of numstr2i. + (literal_refmod_valid): Use real_to_integer. + * symbols.cc (symbol_table_t::registers_t::registers_t): Formatting + fix. + (ERROR_FIELD): Likewise. + (extend_66_capacity): Likewise. + (cbl_occurs_t::subscript_ok): Use real_to_integer, real_from_integer + and real_identical. + * symbols.h (cbl_field_data_t::etc_t::value): Change type from + _Float128 to tree. + (cbl_field_data_t::etc_t::etc_t): Adjust defaulted argument value. + (cbl_field_data_t::cbl_field_data_t): Formatting fix. Use etc() + rather than etc(0). + (cbl_field_data_t::value_of): Change return type from _Float128 to + tree. + (cbl_field_data_t::operator=): Change return and argument type from + _Float128 to tree. + (cbl_field_data_t::valify): Use real_from_string, real_value_truncate + and build_real. + (cbl_field_t::same_as): Use build_zero_cst instead of _Float128(0.0). + +2025-03-24 Iain Sandoe <iain@sandoe.co.uk> + + * cdf-copy.cc: Move host include before system.h + +2025-03-24 Andreas Schwab <schwab@suse.de> + + PR cobol/119390 + * gcobolspec.cc (lang_specific_driver): Use pointer instead of + copying into fixed array. + +2025-03-21 Iain Sandoe <iain@sandoe.co.uk> + + * gcobolspec.cc (lang_specific_driver): Add libstdc++ + for any link line. + +2025-03-21 Iain Sandoe <iain@sandoe.co.uk> + + * gcobolspec.cc (add_arg_lib): Fix typo. + (lang_specific_driver): Arrange to append both -lgcobol + and -static-libgcobol for targets without + HAVE_LD_STATIC_DYNAMIC. + +2025-03-21 Jakub Jelinek <jakub@redhat.com> + + * parse.y: Rename COB_BLOCK to BLOCK_kw, COB_SIGNED to SIGNED_kw and + COB_UNSIGNED to UNSIGNED_kw. + * scan.l: Likewise. + * token_names.h: Regenerate. + +2025-03-21 Richard Biener <rguenther@suse.de> + + * symbols.cc (empty_float, empty_comp5, empty_literal, + empty_conditional, debug_registers, special_registers): Move + global cbl_field_t typed data to ... + (symbol_table_init): ... local scope here. + +2025-03-21 Richard Biener <rguenther@suse.de> + + PR cobol/119241 + * symbols.h: Do not typedef tree. + * cdf.y: Include coretypes.h and tree.h. + * symbols.cc: Likewise. + * symfind.cc: Likewise. + * util.cc: Likewise. + * parse.y: Include coretypes.h and tree.h where appropriate. + Rename BLOCK to COB_BLOCK, SIGNED to COB_SIGNED, UNSIGNED + to COB_UNSIGNED. + * scan.l: Likewise. + * token_names.h: Likewise. + * cobol1.cc: Do not define HOWEVER_GCC_DEFINES_TREE. + * except.cc: Likewise. + * genapi.cc: Likewise. + * gengen.cc: Likewise. + * genmath.cc: Likewise. + * genutil.cc: Likewise. + * structs.cc: Likewise. + +2025-03-20 Iain Sandoe <iain@sandoe.co.uk> + + * cdfval.h (struct cdfval_t): Overload long instead of int64_t. + 2025-03-18 Iain Sandoe <iain@sandoe.co.uk> * gcobolspec.cc (append_rpath): Remove. 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 5b61ae9..a52e6d8 100644 --- a/gcc/cobol/Make-lang.in +++ b/gcc/cobol/Make-lang.in @@ -34,12 +34,18 @@ # - 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)') GCOBC_TARGET_INSTALL_NAME := $(target_noncanonical)-$(shell echo gcobc|sed '$(program_transform_name)') +GCOBOL_HTML_FILES = $(addprefix $(build_htmldir)/gcobol/,gcobol.html gcobol-io.html) + cobol: cobol1$(exeext) cobol.serial = cobol1$(exeext) .PHONY: cobol @@ -65,6 +71,7 @@ cobol1_OBJS = \ cobol/genmath.o \ cobol/gengen.o \ cobol/lexio.o \ + cobol/messages.o \ cobol/parse.o \ cobol/scan.o \ cobol/structs.o \ @@ -87,29 +94,8 @@ cobol1_OBJS = \ # Various #includes in the files copied from gcc/libgcobol need to be modified # so that the .h files can be found. -cobol/charmaps.cc: $(LIB_SOURCE)/charmaps.cc - cp $^ $@ - sed -i "s|\"ec[.]h\"|\"$(LIB_SOURCE)/ec.h\"|g" $@ - sed -i "s|\"common-defs[.]h\"|\"$(LIB_SOURCE)/common-defs.h\"|g" $@ - sed -i "s|\"io[.]h\"|\"$(LIB_SOURCE)/io.h\"|g" $@ - sed -i "s|\"gcobolio[.]h\"|\"$(LIB_SOURCE)/gcobolio.h\"|g" $@ - sed -i "s|\"libgcobol[.]h\"|\"$(LIB_SOURCE)/libgcobol.h\"|g" $@ - sed -i "s|\"gfileio[.]h\"|\"$(LIB_SOURCE)/gfileio.h\"|g" $@ - sed -i "s|\"charmaps[.]h\"|\"$(LIB_SOURCE)/charmaps.h\"|g" $@ - sed -i "s|\"valconv[.]h\"|\"$(LIB_SOURCE)/valconv.h\"|g" $@ - sed -i "s|\"exceptl[.]h\"|\"$(LIB_SOURCE)/exceptl.h\"|g" $@ - -cobol/valconv.cc: $(LIB_SOURCE)/valconv.cc - cp $^ $@ - sed -i "s|\"ec[.]h\"|\"$(LIB_SOURCE)/ec.h\"|g" $@ - sed -i "s|\"common-defs[.]h\"|\"$(LIB_SOURCE)/common-defs.h\"|g" $@ - sed -i "s|\"io[.]h\"|\"$(LIB_SOURCE)/io.h\"|g" $@ - sed -i "s|\"gcobolio[.]h\"|\"$(LIB_SOURCE)/gcobolio.h\"|g" $@ - sed -i "s|\"libgcobol[.]h\"|\"$(LIB_SOURCE)/libgcobol.h\"|g" $@ - sed -i "s|\"gfileio[.]h\"|\"$(LIB_SOURCE)/gfileio.h\"|g" $@ - sed -i "s|\"charmaps[.]h\"|\"$(LIB_SOURCE)/charmaps.h\"|g" $@ - sed -i "s|\"valconv[.]h\"|\"$(LIB_SOURCE)/valconv.h\"|g" $@ - sed -i "s|\"exceptl[.]h\"|\"$(LIB_SOURCE)/exceptl.h\"|g" $@ +cobol/charmaps.cc cobol/valconv.cc: cobol/%.cc: $(LIB_SOURCE)/%.cc + sed -e '/^#include/s,"\([^"]*[^g"].h\)","../../libgcobol/\1",' $^ > $@ LIB_SOURCE_H=$(wildcard $(LIB_SOURCE)/*.h) @@ -175,10 +161,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 $@~ @@ -241,6 +226,7 @@ cobol/scan.o: cobol/scan.cc \ $(srcdir)/cobol/scan_post.h \ $(srcdir)/cobol/symbols.h \ $(srcdir)/cobol/util.h \ + $(srcdir)/cobol/token_names.h \ $(srcdir)/hwint.h \ $(srcdir)/system.h \ $(srcdir)/../include/ansidecl.h \ @@ -257,6 +243,15 @@ cobol/scan.o: cobol/scan.cc \ cobol/cdf.cc \ cobol/parse.cc +# Update token names if the generator script is installed +# (by a developer) and there's been a change. +$(srcdir)/cobol/token_names.h: cobol/parse.cc + @if [ -f $@.gen ]; then \ + $@.gen $(subst .cc,.h,$^) \ + | diff -u $@ - \ + | patch -t --set-time $@ ; \ + fi + # # The src<foo> targets are executed if # ‘--enable-generated-files-in-srcdir’ was specified as a configure @@ -272,8 +267,9 @@ cobol/scan.o: cobol/scan.cc \ # output, and do not require those tools to be installed. # cobol.srcextra: cobol/parse.cc cobol/cdf.cc cobol/scan.cc - ln -f $^ cobol/parse.h cobol/cdf.h $(srcdir)/cobol/ - + -for i in $^ cobol/parse.h cobol/cdf.h; do \ + sed -e '/^#line/s,"\(.*gcc/\)\?cobol/\([^/]*\.\([ylh]\|cc\)\)","\2",' $$i \ + > $(srcdir)/$$i; done # And the cobol1 front end @@ -302,16 +298,14 @@ 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 - mkdir -p $(DESTDIR)$(datadir)/gcobol/udf - $(INSTALL_DATA) $(srcdir)/cobol/udf/* $(DESTDIR)$(datadir)/gcobol/udf/ 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: @@ -321,8 +315,8 @@ cobol.install-pdf: installdirs gcobol.pdf gcobol-io.pdf cobol.install-plugin: -cobol.install-html: installdirs gcobol.html gcobol-io.html - $(INSTALL_DATA) gcobol.html gcobol-io.html $(DESTDIR)$(htmldir)/ +cobol.install-html: installdirs $(GCOBOL_HTML_FILES) + $(INSTALL_DATA) $(GCOBOL_HTML_FILES) $(DESTDIR)$(htmldir)/ cobol.info: cobol.srcinfo: @@ -335,20 +329,22 @@ cobol.srcpdf: gcobol.pdf gcobol-io.pdf ln $^ $(srcdir)/cobol/ gcobol.pdf: $(srcdir)/cobol/gcobol.1 - groff -mdoc -T pdf $^ > $@~ + groff -mdoc -t -T pdf $^ > $@~ @mv $@~ $@ gcobol-io.pdf: $(srcdir)/cobol/gcobol.3 groff -mdoc -T pdf $^ > $@~ @mv $@~ $@ -cobol.html: gcobol.html gcobol-io.html -cobol.srchtml: gcobol.html gcobol-io.html +cobol.html: $(GCOBOL_HTML_FILES) +cobol.srchtml: $(GCOBOL_HTML_FILES) ln $^ $(srcdir)/cobol/ -gcobol.html: $(srcdir)/cobol/gcobol.1 +$(build_htmldir)/gcobol/gcobol.html: $(srcdir)/cobol/gcobol.1 + $(mkinstalldirs) $(build_htmldir)/gcobol mandoc -T html $^ > $@~ @mv $@~ $@ -gcobol-io.html: $(srcdir)/cobol/gcobol.3 +$(build_htmldir)/gcobol/gcobol-io.html: $(srcdir)/cobol/gcobol.3 + $(mkinstalldirs) $(build_htmldir)/gcobol mandoc -T html $^ > $@~ @mv $@~ $@ @@ -358,18 +354,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: @@ -391,3 +393,4 @@ cobol.stagefeedback: stagefeedback-start selftest-cobol: lang_checks += check-cobol + diff --git a/gcc/cobol/TODO b/gcc/cobol/TODO new file mode 100644 index 0000000..02ee0e2 --- /dev/null +++ b/gcc/cobol/TODO @@ -0,0 +1,33 @@ +Below is listed work to be done, hopefully all of it in 2025 for +GCC 16. They are vaguely in priority order, in that addressing more +technical issues may illuminate ways to attack more amorphous ones. + +Portability: + - host/target, for cross-compilation + - OS portability, BSD, macOS, Solaris + - 64-bit portability, LE + - 64-bit portability, BE + - 2025 goal: Compile & run on primary & secondary GCC 15 platforms + https://www.gnu.org/software/gcc/gcc-15/criteria.html + +Correctness: + - LTO ODR, PR 119215 + - cppcheck + - valgrind + - -static produces dynamic + +Efficiency: + - Code size for MOVE 'a' TO FOO(1,1) + - EC checking + +COBOL Features: + - XML, JSON + - MF system functions + - National characters (and Unicode, for IBM) + - GLOBAL and PERFORM declaratives + - dialect feature names (to enable and enumerate) + +GCC features: + - make check-nist + - -Werror, -Wno-<foo> + - -fEC-ALL, -fno-EC-I-O diff --git a/gcc/cobol/cbldiag.h b/gcc/cobol/cbldiag.h index ed754f1..388bc78 100644 --- a/gcc/cobol/cbldiag.h +++ b/gcc/cobol/cbldiag.h @@ -33,14 +33,19 @@ #else #define _CBLDIAG_H +#if GCOBOL_GETENV +#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); /* Location type. Borrowed from parse.h as generated by Bison. */ #if ! defined YYLTYPE && ! defined YYLTYPE_IS_DECLARED @@ -72,39 +77,161 @@ struct YDFLTYPE #endif +struct cbl_loc_t { + int first_line; + int first_column; + int last_line; + int last_column; + + cbl_loc_t( const YYLTYPE& loc ) + : first_line(loc.first_line) + , first_column(loc.first_column) + , last_line(loc.last_line) + , last_column(loc.last_column) + {} + + operator YYLTYPE() const { + return { first_line, first_column, last_line, last_column }; + } +}; + +/* + * Naming Convention: Names end with a letter that indicates + * their kind: + * F fatal, "fatal error: " + * I ice, "internal compiler error: " + * E error, "error: " + * S sorry, "sorry, unimplemented: " + * W warning, "warning: " + * A anachronism, "anachronism: " + * N note, "note: " + * D debug, "debug: " + */ +enum cbl_diag_id_t : uint64_t { + CdfNotFoundW, + CdfParameterW, + + EcUnknownW, + + LexIncludeE, + LexIncludeOkN, + LexIndicatorE, + LexInputN, + LexLineE, + LexPreprocessE, + LexReplaceE, + LexSeparatorE, + + IbmEjectE, + IbmEqualAssignE, + IbmLengthOf, + IbmProcedurePointer, + IbmSectionNegE, + IbmSectionRangeE, + IbmSectionSegmentW, + IbmStopNumber, + IbmVolatileE, + IbmVolatileW, // dialect warning for ignored syntax + + IsoResume, + + MfBinaryLongLong, + MfCallGiving, + MfCdfDollar, + MfComp6, + MfCompX, + MfLevel_1_Occurs, + MfLevel78, + MfMovePointer, + MfReturningNum, + MfUsageTypename, + MfTrailing, + + Par78CdfDefinedW, + ParIconvE, + ParInfoI, + ParLangInfoW, + ParLiteral2W, + ParLocaleW, + ParNoCorrespondingW, + ParNumstrW, + ParUnresolvedProcE, + + SynApplyCommit, + SynFileCodeSet, + SynHighOrderBit, + SynRecordingMode, + SynSetLocaleTo, + SynSetToLocale, + + DiagDiagDiag // always last +}; + +bool cbl_message( cbl_diag_id_t id, const char msg[], ... ) + ATTRIBUTE_GCOBOL_DIAG(2, 3); + +bool cbl_message( cbl_loc_t loc, cbl_diag_id_t id, const char msg[], ... ) + ATTRIBUTE_GCOBOL_DIAG(3, 4); + +bool +dialect_ok( const cbl_loc_t& loc, cbl_diag_id_t id, const char term[], bool ok = true ); + +static inline bool +dialect_not_ok( const cbl_loc_t& loc, cbl_diag_id_t id, const char term[] ) { + return dialect_ok(loc, id, term, false); +} + +// Diagnostic format specifiers are documented in gcc/pretty-print.cc // an error at a location, called from the parser for semantic errors -void error_msg( const YYLTYPE& loc, const char gmsgid[], ... ); +void error_msg( const YYLTYPE& loc, const char gmsgid[], ... ) + ATTRIBUTE_GCOBOL_DIAG(2, 3); -void dialect_error( const YYLTYPE& loc, const char term[], const char dialect[] ); +bool +warn_msg( const YYLTYPE& loc, const char gmsgid[], ... ) + ATTRIBUTE_GCOBOL_DIAG(2, 3); +// an error that uses token_location, not yylloc +void error_msg_direct( const char gmsgid[], ... ) + ATTRIBUTE_GCOBOL_DIAG(1, 2); // 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(cbl_diag_id_t id, const char *gmsgid, ...) + ATTRIBUTE_GCOBOL_DIAG(2, 3); // 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 ); +void gcc_location_dump(); + // tree.h defines yy_flex_debug as a macro because options.h #if ! defined(yy_flex_debug) template <typename LOC> static void location_dump( const char func[], int line, const char tag[], const LOC& loc) { - extern int yy_flex_debug; - if( yy_flex_debug && getenv("update_location") ) - fprintf(stderr, "%s:%d: %s location (%d,%d) to (%d,%d)\n", - func, line, tag, - loc.first_line, loc.first_column, loc.last_line, loc.last_column); + extern int yy_flex_debug; // cppcheck-suppress shadowVariable + if( yy_flex_debug ) { + const char *detail = gcobol_getenv("update_location"); + if( detail ) { // cppcheck-suppress knownConditionTrueFalse + fprintf(stderr, "%s:%d: %s location (%d,%d) to (%d,%d)\n", + func, line, tag, + loc.first_line, loc.first_column, loc.last_line, loc.last_column); + if( *detail == '2' ) gcc_location_dump(); + } + } } #endif // defined(yy_flex_debug) diff --git a/gcc/cobol/cdf-copy.cc b/gcc/cobol/cdf-copy.cc index 179dbac..11be9b8 100644 --- a/gcc/cobol/cdf-copy.cc +++ b/gcc/cobol/cdf-copy.cc @@ -34,13 +34,13 @@ // // We regret any confusion engendered. +#include "config.h" + #include "cobol-system.h" #include "cbldiag.h" #include "util.h" #include "copybook.h" -#include <glob.h> - #define COUNT_OF(X) (sizeof(X) / sizeof(X[0])) /* @@ -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 12d11e7..72e46b3f 100644 --- a/gcc/cobol/cdf.y +++ b/gcc/cobol/cdf.y @@ -30,6 +30,9 @@ %{ #include "cobol-system.h" +#include "coretypes.h" +#include "tree.h" +#undef yy_flex_debug #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" #include "util.h" @@ -92,7 +95,7 @@ void input_file_status_notify(); } \ location_dump("cdf.c", __LINE__, "current", (Current)); \ input_file_status_notify(); \ - gcc_location_set( location_set(Current) ); \ + location_set(Current); \ } while (0) %} @@ -102,14 +105,14 @@ void input_file_status_notify(); using std::map; - static map<std::string, cdfval_t> dictionary; - #pragma GCC diagnostic push #pragma GCC diagnostic ignored "-Wunused-function" static bool cdfval_add( const char name[], const cdfval_t& value, bool override = false ) { + cdf_values_t& dictionary( cdf_dictionary() ); + if( scanner_parsing() ) { if( ! override ) { if( dictionary.find(name) != dictionary.end() ) return false; @@ -120,6 +123,8 @@ void input_file_status_notify(); } static void cdfval_off( const char name[] ) { + cdf_values_t& dictionary( cdf_dictionary() ); + if( scanner_parsing() ) { auto p = dictionary.find(name); if( p == dictionary.end() ) { @@ -146,84 +151,28 @@ void input_file_status_notify(); cdfval_t operator/( const cdfval_base_t& lhs, const cdfval_base_t& rhs ); cdfval_t negate( cdfval_base_t lhs ); + cbl_field_t + cdf_literalize( const std::string& name, const cdfval_t& value ); + } %{ 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 ) { + cbl_enabled_exceptions_t& enabled_exceptions( cdf_enabled_exceptions() ); + + for( auto elem : turn.exception_files() ) { std::set<size_t> files(elem.second.begin(), elem.second.end()); - enabled_exceptions.turn_on_off(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; } %} @@ -238,70 +187,81 @@ 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 367 NUMBER 304 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 +%type <number> cdf_stackable + +%token BY 488 +%token COPY 364 +%token CDF_DISPLAY 386 ">>DISPLAY" +%token IN 606 %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 306 "numeric literal" +%token OF 687 +%token PSEUDOTEXT 723 +%token REPLACING 745 +%token LITERAL 299 +%token SUPPRESS 378 + +%token LSUB 369 "(" +%token SUBSCRIPT 377 RSUB 374 ")" + +%token CDF_DEFINE 385 ">>DEFINE" +%token CDF_IF 387 ">>IF" +%token CDF_ELSE 388 ">>ELSE" +%token CDF_END_IF 389 ">>END-IF" +%token CDF_EVALUATE 390 ">>EVALUATE" +%token CDF_WHEN 391 ">>WHEN" +%token CDF_END_EVALUATE 392 ">>END-EVALUATE" + +%token ALL 452 +%token CALL_CONVENTION 393 ">>CALL-CONVENTION" +%token COBOL_WORDS 382 ">>COBOL-WORDS" +%token CDF_PUSH 396 ">>PUSH" +%token CDF_POP 397 ">>POP" +%token SOURCE_FORMAT 398 ">>SOURCE FORMAT" + +%token AS 470 CONSTANT 363 DEFINED 365 %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 699 PARAMETER_kw 370 "PARAMETER" +%token OFF 688 OVERRIDE 371 +%token THRU 950 +%token TRUE_kw 815 "True" -%token CALL_COBOL 389 "CALL" -%token CALL_VERBATIM 390 "CALL (as C)" +%token CALL_COBOL 394 "CALL" +%token CALL_VERBATIM 395 "CALL (as C)" -%token TURN 805 CHECKING 486 LOCATION 639 ON 679 WITH 831 +%token TURN 817 CHECKING 498 LOCATION 650 ON 690 WITH 844 -%left OR 930 -%left AND 931 -%right NOT 932 -%left '<' '>' '=' NE 933 LE 934 GE 935 +%left OR 951 +%left AND 952 +%right NOT 953 +%left '<' '>' EQ 298 "EQUAL" NE 954 LE 955 GE 956 %left '-' '+' %left '*' '/' -%right NEG 937 +%right NEG 958 %define api.prefix {ydf} %define api.token.prefix{YDF_} @@ -319,8 +279,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; } ; @@ -333,6 +293,8 @@ complete: cdf_define | cdf_display | cdf_turn | cdf_call_convention + | cdf_push + | cdf_pop ; /* @@ -384,6 +346,7 @@ cdf_define: CDF_DEFINE cdf_constant NAME as cdf_expr[value] override } if( !cdfval_add( $NAME, cdfval_t($value), $override) ) { error_msg(@NAME, "name already in dictionary: %s", $NAME); + cdf_values_t& dictionary( cdf_dictionary() ); const cdfval_t& entry = dictionary[$NAME]; if( entry.filename ) { error_msg(@NAME, "%s previously defined in %s:%d", @@ -393,8 +356,13 @@ cdf_define: CDF_DEFINE cdf_constant NAME as cdf_expr[value] override } YYERROR; } + if( symbols_begin() < symbols_end() ) { + cbl_field_t field = cdf_literalize($NAME, $value); + symbol_field_add(current_program_index(), &field); + } + } - | CDF_DEFINE cdf_constant NAME '=' cdf_expr[value] override + | CDF_DEFINE cdf_constant NAME EQ cdf_expr[value] override { /* accept, but as error */ if( scanner_parsing() ) { error_msg(@NAME, "CDF error: %s = value invalid", $NAME); @@ -413,21 +381,24 @@ cdf_define: CDF_DEFINE cdf_constant NAME as cdf_expr[value] override * available regardless. */ { - if( 0 == dictionary.count($NAME) ) { - yywarn("CDF: '%s' is defined AS PARAMETER " - "but was not defined", $NAME); + if( 0 == cdf_dictionary().count($NAME) ) { + cbl_message(@NAME, CdfParameterW, + "CDF: '%s' is defined AS PARAMETER " + "but was not defined", $NAME); } } | 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"); } } ; @@ -440,8 +411,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(); } ; @@ -454,28 +425,55 @@ cdf_call_convention: } ; +cdf_push: CDF_PUSH cdf_stackable { + switch( $cdf_stackable ) { + case YDF_ALL: cdf_push(); break; + case YDF_CALL_CONVENTION: cdf_push_call_convention(); break; + case YDF_CDF_DEFINE: cdf_push_dictionary(); break; + case YDF_COBOL_WORDS: cdf_push_current_tokens(); break; + case YDF_SOURCE_FORMAT: cdf_push_source_format(); break; + default: gcc_unreachable(); + } + } + ; +cdf_pop: CDF_POP cdf_stackable { + switch( $cdf_stackable ) { + case YDF_ALL: cdf_pop(); break; + case YDF_CALL_CONVENTION: cdf_pop_call_convention(); break; + case YDF_CDF_DEFINE: cdf_pop_dictionary(); break; + case YDF_COBOL_WORDS: cdf_pop_current_tokens(); break; + case YDF_SOURCE_FORMAT: cdf_pop_source_format(); break; + default: gcc_unreachable(); + } + } + ; + +cdf_stackable: ALL { $$ = YDF_ALL; } + | CALL_CONVENTION { $$ = YDF_CALL_CONVENTION; } + | COBOL_WORDS { $$ = YDF_COBOL_WORDS; } + | CDF_DEFINE { $$ = YDF_CDF_DEFINE; } + | SOURCE_FORMAT { $$ = YDF_SOURCE_FORMAT; } + ; except_names: except_name | except_names except_name ; 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); } ; @@ -488,7 +486,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); } } ; @@ -507,7 +505,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; } @@ -526,18 +523,18 @@ cdf_eval_obj: cdf_cond_expr ; cdf_cond_expr: BOOL - | NAME DEFINED[maybe] + | NAME DEFINED { + cdf_values_t& dictionary( cdf_dictionary() ); 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"); } } @@ -567,7 +564,7 @@ cdf_reloper: cdf_relexpr cdf_relexpr: cdf_relexpr '<' cdf_expr { $$ = $1(@1) < $3(@3); } | cdf_relexpr LE cdf_expr { $$ = $1(@1) <= $3(@3); } - | cdf_relexpr '=' cdf_expr { + | cdf_relexpr EQ cdf_expr { $$ = cdfval_t(false); if( ( $1.string && $3.string) || (!$1.string && !$3.string) ) @@ -577,7 +574,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 @@ -591,7 +588,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); } @@ -610,12 +607,14 @@ cdf_expr: cdf_expr '+' cdf_expr { $$ = $1(@1) + $3(@3); } ; cdf_factor: NAME { + cdf_values_t& dictionary( cdf_dictionary() ); auto that = dictionary.find($1); if( that != dictionary.end() ) { $$ = that->second; } else { if( ! scanner_parsing() ) { - yywarn("CDF skipping: no such variable '%s' (ignored)", $1); + cbl_message(CdfNotFoundW, + "CDF skipping: no such variable '%s'", $1); } else { error_msg(@NAME, "CDF error: no such variable '%s'", $1); } @@ -627,7 +626,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; } @@ -645,7 +644,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] @@ -653,8 +652,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; } } ; @@ -709,6 +708,7 @@ name_any: namelit name_one: NAME { + cdf_values_t& dictionary( cdf_dictionary() ); cdf_arg_t arg = { YDF_NAME, $1 }; auto p = dictionary.find($1); @@ -723,6 +723,7 @@ name_one: NAME namelit: name { + cdf_values_t& dictionary( cdf_dictionary() ); cdf_arg_t arg = { YDF_NAME, $1 }; auto p = dictionary.find($1); @@ -803,6 +804,7 @@ location_set( const YYLTYPE& loc ) { bool // used by cobol1.cc defined_cmd( const char arg[] ) { + cdf_values_t& dictionary( cdf_dictionary() ); cdfval_t value(1); char *name = xstrdup(arg); @@ -825,7 +827,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); } @@ -924,7 +927,8 @@ static int ydflex(void) { } bool -cdf_value( const char name[], cdfval_t value ) { +cdf_value( const char name[], const cdfval_t& value ) { + cdf_values_t& dictionary( cdf_dictionary() ); auto p = dictionary.find(name); if( p != dictionary.end() ) return false; @@ -935,6 +939,7 @@ cdf_value( const char name[], cdfval_t value ) { const cdfval_t * cdf_value( const char name[] ) { + cdf_values_t& dictionary( cdf_dictionary() ); auto p = dictionary.find(name); if( p == dictionary.end() ) return NULL; @@ -951,8 +956,11 @@ verify_integer( const YDFLTYPE& loc, const cdfval_base_t& val ) { return true; } -cdfval_base_t& +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 1453f2a..cc474a2 100644 --- a/gcc/cobol/cdfval.h +++ b/gcc/cobol/cdfval.h @@ -32,18 +32,26 @@ #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; const char *string; int64_t number; - cdfval_base_t& operator()( const YDFLTYPE& loc ); + const cdfval_base_t& operator()( const YDFLTYPE& loc ); }; struct cdf_arg_t { @@ -65,35 +73,43 @@ 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 ) // 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( int64_t value ) + cdfval_t( int 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 ) + explicit cdfval_t( const REAL_VALUE_TYPE& r ) : lineno(yylineno), filename(cobol_filename()) { cdfval_base_t::off = false; cdfval_base_t::string = NULL; + 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); @@ -104,10 +120,14 @@ struct cdfval_t : public cdfval_base_t { int64_t as_number() const { assert(is_numeric()); return number; } }; -bool -cdf_value( const char name[], cdfval_t value ); - const cdfval_t * cdf_value( const char name[] ); +bool +cdf_value( const char name[], const cdfval_t& value ); + +typedef std::map<std::string, cdfval_t> cdf_values_t; + +cdf_values_t& cdf_dictionary(); + #endif diff --git a/gcc/cobol/cobol-system.h b/gcc/cobol/cobol-system.h index 81529bd..828f4f5 100644 --- a/gcc/cobol/cobol-system.h +++ b/gcc/cobol/cobol-system.h @@ -53,7 +53,6 @@ #include <deque> #include <numeric> #include <limits> -#include <cmath> #include <unordered_map> #include <unordered_set> @@ -61,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 08af367..5f1260e 100644 --- a/gcc/cobol/cobol1.cc +++ b/gcc/cobol/cobol1.cc @@ -20,16 +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" -#define HOWEVER_GCC_DEFINES_TREE 1 +#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" @@ -40,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 @@ -167,8 +165,8 @@ create_our_type_nodes_init() long_double_ten_node = build_real_from_int_cst( LONGDOUBLE, build_int_cst_type(INT,10)); - sizeof_size_t = build_int_cst_type(SIZE_T, sizeof(size_t)); - sizeof_pointer = build_int_cst_type(SIZE_T, sizeof(void *)); + sizeof_size_t = build_int_cst_type(SIZE_T, int_size_in_bytes(SIZE_T)); + sizeof_pointer = build_int_cst_type(SIZE_T, int_size_in_bytes(VOID_P)); bool_true_node = build2(EQ_EXPR, integer_type_node, @@ -295,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 @@ -319,7 +317,7 @@ enable_exceptions( bool enable ) { NULL != (name = strtok(name, ",")); name = NULL ) { ec_type_t type = ec_type_of(name); if( type == ec_none_e ) { - yywarn("unrecognized exception '%s' was ignored", name); + cbl_message(EcUnknownW, "unrecognized exception '%s'", name); continue; } ec_disposition_t disposition = ec_type_disposition(type); @@ -330,17 +328,21 @@ enable_exceptions( bool enable ) { } } +void cobol_warning( cbl_diag_id_t id, int yn, bool ); + static bool cobol_langhook_handle_option (size_t scode, - const char *arg ATTRIBUTE_UNUSED, + const char *arg, HOST_WIDE_INT value, - int kind ATTRIBUTE_UNUSED, + int kind, location_t loc ATTRIBUTE_UNUSED, const struct cl_option_handlers *handlers ATTRIBUTE_UNUSED) { // process_command (decoded_options_count, decoded_options); enum opt_code code = (enum opt_code) scode; + auto super_kind = diagnostics::kind(kind); + bool warning_as_error = super_kind == diagnostics::kind::error; switch(code) { @@ -358,24 +360,31 @@ 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; case OPT_fdefaultbyte: + // cobol_default_byte is an unsigned ing wsclear(cobol_default_byte); return true; - case OPT_fflex_debug: + case OPT_fflex_debug: // cppcheck-suppress syntaxError // The need for this is a mystery yy_flex_debug = 1; cobol_set_debugging( true, yy_debug == 1, cobol_trace_debug == 1 ); return true; + case OPT_fyacc_debug: yy_debug = 1; cobol_set_debugging(yy_flex_debug == 1, true, cobol_trace_debug == 1 ); return true; + case OPT_ftrace_debug: cobol_set_debugging( yy_flex_debug == 1, yy_debug == 1, true ); return true; @@ -386,10 +395,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; @@ -402,20 +407,24 @@ cobol_langhook_handle_option (size_t scode, return true; case OPT_dialect: + // gcc disallows 0 as an enumerated value, so we used 0x10 for iso. + if( cobol_dialect == 0x100 ) cobol_dialect = 0; cobol_dialect_set(cbl_dialect_t(cobol_dialect)); return true; case OPT_fsyntax_only: mode_syntax_only(identification_div_e); break; + case OPT_preprocess: if( ! preprocess_filter_add(arg) ) { cbl_errx( "could not execute preprocessor %s", arg); } return true; + case OPT_include: - if( ! include_file_add(cobol_include) ) { - cbl_errx( "could not include %s", cobol_include); + if( ! include_file_add(arg) ) { + cbl_errx( "could not include %s", arg); } return true; @@ -436,6 +445,194 @@ cobol_langhook_handle_option (size_t scode, cobol_gcobol_feature_set(feature_internal_ebcdic_e); return true; + // Warnings and errors + + case OPT_Wbinary_long_long: + cobol_warning(MfBinaryLongLong, binary_long_long, warning_as_error); + return true; + + case OPT_Wcall_giving: + cobol_warning(MfCallGiving, call_giving, warning_as_error); + return true; + + case OPT_Wcdf_dollar: + cobol_warning(MfCdfDollar, cdf_dollar, warning_as_error); + return true; + + case OPT_Wcomp_6: + cobol_warning(MfComp6, comp_6, warning_as_error); + return true; + + case OPT_Wcomp_x: + cobol_warning(MfCompX, comp_x, warning_as_error); + return true; + + case OPT_Winspect_trailing: + cobol_warning(MfTrailing, inspect_trailing, warning_as_error); + return true; + + case OPT_Wlevel_1_occurs: + cobol_warning(MfLevel_1_Occurs, level_1_occurs, warning_as_error); + return true; + + case OPT_Wlevel_78_defined: + cobol_warning(Par78CdfDefinedW, level_78_defined, warning_as_error); + return true; + + case OPT_Wmove_pointer: + cobol_warning(MfMovePointer, move_pointer, warning_as_error); + return true; + + case OPT_Wlevel_78: + cobol_warning(MfLevel78, level_78, warning_as_error); + return true; + + case OPT_Wreturning_number: + cobol_warning(MfReturningNum, returning_number, warning_as_error); + return true; + + case OPT_Wusage_typename: + cobol_warning(MfUsageTypename, usage_typename, warning_as_error); + return true; + + case OPT_Wbad_line_directive: + cobol_warning(LexLineE, bad_line_directive, warning_as_error); + return true; + + case OPT_Wequal_assign: + cobol_warning(IbmEqualAssignE, equal_assign, warning_as_error); + return true; + + case OPT_Wbad_numeric: + cobol_warning(ParNumstrW, bad_numeric, warning_as_error); + return true; + + case OPT_Wcdf_invalid_parameter: + cobol_warning(CdfParameterW, cdf_invalid_parameter, warning_as_error); + return true; + + case OPT_Wcdf_name_not_found: + cobol_warning(CdfNotFoundW, cdf_name_not_found, warning_as_error); + return true; + + case OPT_Wcopybook_found: + cobol_warning(LexInputN, copybook_found, warning_as_error); + return true; + + case OPT_Wec_unknown: + cobol_warning(EcUnknownW, ec_unknown, warning_as_error); + return true; + + case OPT_Wentry_convention: + cobol_warning(ParInfoI, entry_convention, warning_as_error); + return true; + + case OPT_Wiconv_error: + cobol_warning(ParIconvE, iconv_error, warning_as_error); + return true; + + case OPT_Winclude_file_found: + cobol_warning(LexIncludeOkN, include_file_found, warning_as_error); + return true; + + case OPT_Winclude_file_not_found: + cobol_warning(LexIncludeE, include_file_not_found, warning_as_error); + return true; + + case OPT_Wliteral_concat: + cobol_warning(ParLiteral2W, literal_concat, warning_as_error); + return true; + + case OPT_Wlocale_error: + cobol_warning(ParLocaleW, locale_error, warning_as_error); + return true; + + case OPT_Wmove_corresponding: + cobol_warning(ParNoCorrespondingW, warn_corresponding, warning_as_error); + return true; + + case OPT_Wnllanginfo_error: + cobol_warning(ParLangInfoW, nllanginfo_error, warning_as_error); + return true; + + case OPT_Wlength_of: + cobol_warning(IbmLengthOf, cobol_length_of, warning_as_error); + return true; + + case OPT_Wpreprocessor_error: + cobol_warning(ParLangInfoW, preprocessor_error, warning_as_error); + return true; + + case OPT_Wprocedure_pointer: + cobol_warning(IbmProcedurePointer, procedure_pointer, warning_as_error); + return true; + + case OPT_Wprocedure_not_found: + cobol_warning(ParUnresolvedProcE, procedure_not_found, warning_as_error); + return true; + + case OPT_Wreplace_error: + cobol_warning(LexReplaceE, replace_error, warning_as_error); + return true; + + case OPT_Wsegment_error: + cobol_warning(IbmSectionRangeE, segment_error, warning_as_error); + return true; + + case OPT_Wsegment_negative: + cobol_warning(IbmSectionNegE, segment_negative, warning_as_error); + return true; + + case OPT_Wsegment: + cobol_warning(IbmSectionSegmentW, cobol_segment, warning_as_error); + return true; + + case OPT_Wcobol_eject: + cobol_warning(IbmEjectE, cobol_eject, warning_as_error); + return true; + + case OPT_Woperator_space: + cobol_warning(LexSeparatorE, operator_space, warning_as_error); + return true; + + case OPT_Wstop_number: + cobol_warning(IbmStopNumber, stop_number, warning_as_error); + return true; + + case OPT_Wstray_indicator: + cobol_warning(LexIndicatorE, stray_indicator, warning_as_error); + return true; + + case OPT_Wcobol_volatile: + // If arg is true, the error becoomes a warning + cobol_warning(IbmVolatileE, cobol_volatile, warning_as_error); + cobol_warning(IbmVolatileW, cobol_volatile, warning_as_error); + return true; + + case OPT_Wcobol_resume: + cobol_warning(IsoResume, cobol_resume, warning_as_error); + return true; + + case OPT_Wapply_commit: + cobol_warning(SynApplyCommit, apply_commit, warning_as_error); + return true; + + case OPT_Whigh_order_bit: + cobol_warning(SynHighOrderBit, high_order_bit, warning_as_error); + return true; + + case OPT_Wfile_code_set: + cobol_warning(SynFileCodeSet, file_code_set, warning_as_error); + return true; + + case OPT_Wset_locale_to: + cobol_warning(SynSetLocaleTo, set_locale_to, warning_as_error); + return true; + + case OPT_Wset_to_locale: + cobol_warning(SynSetToLocale, set_to_locale, warning_as_error); + return true; + default: break; } @@ -511,14 +708,6 @@ cobol_langhook_type_for_mode (enum machine_mode mode, int unsignedp) return NULL; } -////static tree -////cobol_langhook_type_for_size (unsigned int bits ATTRIBUTE_UNUSED, -//// int unsignedp ATTRIBUTE_UNUSED) -//// { -//// gcc_unreachable (); -//// return NULL; -//// } - /* Record a builtin function. We just ignore builtin functions. */ static tree @@ -573,7 +762,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..c900c45 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, @@ -86,24 +86,30 @@ namespace dts { #if __cpp_exceptions static const char msg[] = "input not NUL-terminated"; throw std::domain_error( msg ); -#else - eoinput = strchr(input, '\0'); #endif } - if( eoinput == NULL ) eoinput = strchr(input, '\0'); auto ncm = re.size(); cm.resize(ncm); std::vector <regmatch_t> cms(ncm); - int erc = regexec( &re, input, ncm, cms.data(), 0 ); if( erc != 0 ) return false; +#if __cpp_exceptions + // This is not correct at all, but current use depends on current behavior. + // The following line is excluded from the GCC build, which is compiled + // without __cpp_exceptions. parse_copy_directive (for one) depends on + // regex_search returning true even if the match is beyond eoinput. + if( eoinput < cm[0].second ) return false; + // Correct behavior would return match only between input and eoinput. + // Because regex(3) uses a NUL terminator, it may match text between + // eoinput and the NUL. +#endif std::transform( cms.begin(), cms.end(), cm.begin(), [input]( const regmatch_t& m ) { return csub_match( input, m ); } ); return true; } -}; +} diff --git a/gcc/cobol/except.cc b/gcc/cobol/except.cc index 5374201..31112d1 100644 --- a/gcc/cobol/except.cc +++ b/gcc/cobol/except.cc @@ -32,7 +32,6 @@ #include "cobol-system.h" #include "coretypes.h" #include "tree.h" -#define HOWEVER_GCC_DEFINES_TREE 1 #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" #include "util.h" @@ -44,6 +43,7 @@ #include "gengen.h" #include "../../libgcobol/exceptl.h" #include "util.h" +#include "genutil.h" #pragma GCC diagnostic ignored "-Wmissing-field-initializers" @@ -51,7 +51,7 @@ static const ec_descr_t * ec_type_descr( ec_type_t type ) { auto p = std::find( __gg__exception_table, __gg__exception_table_end, type ); if( p == __gg__exception_table_end ) { - cbl_internal_error("no such exception: 0x%04x", type); + cbl_internal_error("no such exception: 0x%x", type); } return p; } @@ -75,107 +75,130 @@ ec_level( ec_type_t ec ) { return 3; } -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}", + for( auto& elem : *this ) { // cppcheck-suppress constVariableReference + 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::remove_if cannot be used with std::set because its elements are const. - * 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( end() != (p = std::find_if( begin(), end(), - [ec = type]( const auto& elem ) { - return - !elem.enabled && - ec_cmp(ec, elem.ec); } )) ) { - erase(p); - } - } else { - for( size_t file: files ) { - auto p = begin(); - while( end() != (p = std::find_if( begin(), end(), - [ec = type, file]( const auto& elem ) { - return - !elem.enabled && - file == elem.file && - ec_cmp(ec, elem.ec); } )) ) { - erase(p); - } - } + auto elem = cbl_enabled_exception_t(location, type); + apply(enabled, elem); + return; } - auto elem = cbl_enabled_exception_t(enabled, location, type); - apply(elem); - return true; + for( size_t file: files ) { + auto elem = cbl_enabled_exception_t(location, type, file); + apply(enabled, elem); + } + 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. @@ -184,47 +207,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 ) { @@ -234,66 +244,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 @@ -316,48 +266,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); + static auto isection = new_temporary(FldNumericBin5); + static auto index = 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(); + /* + * 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..6869f22 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(EcUnknownW, "exception %qs", 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..fa9f609 100755 --- a/gcc/cobol/gcobc +++ b/gcc/cobol/gcobc @@ -35,6 +35,10 @@ ## output set the mode variable. Everything else is appended to the ## opts variable. ## +## - -fPIC is added to the command line if $mode is "-shared". That +## option applies only to "certain machines", per the gcc info +## manual. For this script to be portable across machines, -fPIC +## would have to be set more judiciously. if [ "$COBCPY" ] then @@ -73,7 +77,7 @@ fi exit_status=0 skip_arg= -opts="$copydir ${dialect:--dialect mf} $includes" +opts="$copydir $includes" mode=-shared incomparable="has no comparable gcobol option" @@ -103,6 +107,9 @@ $0 recognizes the following GnuCOBOL cobc output mode options: $0 recognizes the following GnuCOBOL cobc compilation options: -C -d, --debug + -D + -A + -Q -E -g --coverage @@ -112,11 +119,12 @@ $0 recognizes the following GnuCOBOL cobc compilation options: --fixed -F, --free -fimplicit-init - -h, --help - -save-temps= - -save-temps - -std=mvs - -std=mf + -h, --help + -save-temps= + -save-temps + -std=mvs -std=mvs-strict + -std=mf -std=mf-strict + -std=cobol85 -std=cobol2002 -std=cobol2014 Options that are the same in gcobol and cobc are passed through verbatim. Options that have no analog in gcobol produce a warning message. To produce this message, use -HELP. @@ -127,11 +135,14 @@ To override, set the gcobol environment variable. EOF } +dialect="mf gnu" +out_set="" +first="" + # -# Simply iterate over the command-line tokens. We can't use getopts -# here because it's not designed for single-dash words (e.g. -shared). +# Iterate over the command-line tokens. We can't use getopts here +# because it's not designed for single-dash words (e.g. -shared). # - for opt in "$@" do if [ "$skip_arg" ] @@ -142,41 +153,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 +381,18 @@ do -fnot-register=*) warn "$opt" ;; -fregister=*) warn "$opt" ;; - -fformat=auto ) ;; # gcobol and gnucobol default + -fformat=auto) ;; # gcobol and gnucobol default -fixed | --fixed | -fformat=fixed | -fformat=variable | -fformat=xcard) # note: variable + xcard are only _more similar_ to fixed than free, # (with changing right-column to 250/255, which isn't supported in gcobol, yet) - opts="$opts -ffixed-form" - ;; - - -F | -free | --free | -fformat=free | -fformat=* ) - # note: "all other formats" are only _more similar_ to free than fixed - opts="$opts -ffree-form" - ;; + opts="$opts -ffixed-form" + ;; + -F | -free | --free | -fformat=free | -fformat=*) + # note: "all other formats" are only _more similar_ to free than fixed + opts="$opts -ffree-form" + ;; -h | --help) opts="$opts --help" ;; @@ -392,7 +418,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 +434,37 @@ do export GCOBOL_TEMPDIR="$opt" ;; -save-temps) export GCOBOL_TEMPDIR="${PWD:-$(pwd)}" - ;; - # -shared is identical + ;; + # -shared is identical - -std=mvs) opts="$opts -dialect ibm" + -std=mvs | -std=mvs-strict | -std=ibm | -std=ibm-strict) dialect=ibm ;; - -std=mf) opts="$opts -dialect mf" + -std=mf | -std=mf-strict) dialect=mf + ;; + # GnuCOBOL's default and GCC's dialect for GnuCOBOL + -std=default) dialect=gnu + ;; + # GCC COBOL targets COBOL2024 "mostly backward to COBOL85" + -std=cobol*) dialect="" + ;; + -std=*) + dialect="" + warn "$opt (unkown dialect)" ;; - -t | -T | -tlines=* | -P | -P=* | -X | --Xref) - warn "$opt (no listing)" + -P | -P=* | -X | --Xref) + warn "$opt (no listing)" + ;; + -t | -T) + # note: -P has an _optional_ arg, so we leave it above + ignore_arg "$opt (no listing)" + ;; + -q | --brief) warn "$opt" + ;; + -v | --verbose) opts="$opts -V" + ;; + # note: we want -dumpversion to be passed to gcc + -V | --version | -version) opts="$opts --version" ;; - -q | --brief) warn "$opt" - ;; - -v | --verbose) opts="$opts -V" - ;; - # note: we want -dumpversion to be passed to gcc - -V | --version | -version) opts="$opts --version" - ;; - # pass through, strangely -Wall is not supported -w | -W | -Wextra) opts="$opts $opt" ;; @@ -432,7 +477,25 @@ do -x) mode= ;; - *) opts="$opts $opt" # pass through + -) output_name=a.out # nonnull to prevent overriding gcc default + opts="$opts /dev/stdin" + ;; + + # First file name argument is default output filename. + *) if [ -z "$output_name" -a -e "$opt" ] + 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 @@ -451,6 +514,11 @@ fi # To override the default gcobol, set the "gcobol" environment variable. gcobol="${gcobol:-${0%/*}/gcobol}" +if [ "$dialect" ] +then + dialect=$(echo $dialect | sed -E 's/[[:alnum:]]+/-dialect &/g') +fi + if [ "$echo" ] then echo $gcobol $mode $opts @@ -462,4 +530,4 @@ then set -x fi -exec $gcobol $mode $opts +exec $gcobol $mode $dialect $opts diff --git a/gcc/cobol/gcobol.1 b/gcc/cobol/gcobol.1 index 64c017c..92b2226 100644 --- a/gcc/cobol/gcobol.1 +++ b/gcc/cobol/gcobol.1 @@ -1,4 +1,4 @@ -.ds lang COBOL + .ds lang COBOL .ds gcobol GCC\ \*[lang]\ Front-end .ds isostd ISO/IEC 1989:2023 .Dd \& February 2025 @@ -31,15 +31,61 @@ .Op Fl preprocess Ar preprocess-filter .Op Fl fflex-debug .Op Fl fyacc-debug +.\" warnings +.Op Fl Wno-apply-commit +.Op Fl Wno-file-code-set +.Op Fl Wno-high-order-bit +.Op Fl Wno-bad-line-directive +.Op Fl Wno-bad-numeric +.Op Fl Wno-binary-long-long +.Op Fl Wno-call-giving +.Op Fl Wno-cdf-dollar +.Op Fl Wno-cdf-invalid-parameter +.Op Fl Wno-cdf-name-not-found +.Op Fl Wno-cobol-eject +.Op Fl Wno-cobol-resume +.Op Fl Wno-cobol-volatile +.Op Fl Wno-comp-6 +.Op Fl Wno-comp-x +.Op Fl Wno-copybook-found +.Op Fl Wno-ec-unknown +.Op Fl Wno-entry-convention +.Op Fl Wno-iconv-error +.Op Fl Wno-include-file-found +.Op Fl Wno-include-file-not-found +.Op Fl Wno-inspect-trailing +.Op Fl Wno-length-of +.Op Fl Wno-level-1-occurs +.Op Fl Wno-level-78 +.Op Fl Wno-level-78-defined +.Op Fl Wno-literal-concat +.Op Fl Wno-locale-error +.Op Fl Wno-move-corresponding +.Op Fl Wno-move-pointer +.Op Fl Wno-nllanginfo-error +.Op Fl Wno-operator-space +.Op Fl Wno-preprocessor-error +.Op Fl Wno-procedure-not-found +.Op Fl Wno-procedure-pointer +.Op Fl Wno-replace-error +.Op Fl Wno-returning-number +.Op Fl Wno-segment-error +.Op Fl Wno-segment-negative +.Op Fl Wno-stop-number +.Op Fl Wno-stray-indicator +.Op Fl Wno-usage-typename +.Op Fl Wno-recording-mode +.Op Fl Wno-set-locale-to +.Op Fl Wno-set-to-locale .Ar filename Op ... . .Sh DESCRIPTION .Nm -compiles \*[lang] source code to object code, and optionally produces an -executable binary or shared object. As a GCC component, it accepts +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 +143,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 +194,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 +234,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 +280,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 @@ -273,30 +329,66 @@ because its value is determined at run time. By default, .Nm accepts \*[lang] syntax as defined by \*[isostd], with some -extensions for backward compatibility with COBOL-85. To make the -compiler more generally useful, some additional syntax is supported by -this option. -.Pp -The value of +extensions for backward compatibility with COBOL-85. Additional syntax is supported with this option. The value of .Ar dialect-name may be -.Bl -tag -compact +.Bl -tag .It ibm -to indicate IBM COBOL 6.3 syntax, specifically -.D1 STOP <number>. +to indicate IBM COBOL 6.4 syntax: +.Bl -bullet -compact +.It +.Sy EJECT +.It +.Sy EQUAL +as assignment operator +.It +.Sy "LENGTH OF" +.It +.Sy "PROCEDURE POINTER" +.It +.Sy SECTION +segment +.It +.Sy STOP +<number> +.It +.Sy VOLATILE +.El .It gnu -to indicate GnuCOBOL syntax +to indicate GnuCOBOL syntax, generally compatible with MicroFocus. .It mf -to indicate MicroFocus syntax, specifically +to indicate MicroFocus syntax: +.Bl -bullet -compact +.It +.Sy BINARY-LONG-LONG +.It +.Sy CALL ... GIVING +.It +.Sy CDF \[Do]IF +.It +.Sy COMPUTATIONAL-6 +.It +.Sy COMPUTATIONAL +used with +.Sy PICTURE X +.It +.Sy INSPECT ... TRAILING +.It +.Sy OCCURS +at +.Sy "LEVEL 01" +.It .Sy LEVEL 78 -constants. +constants +.It +.Sy MOVE POINTER +.It +.Sy RETURNING +<number> +.It +.Sy USAGE IS TYPENAME +.El .El -.Pp -Only a few such non-standard constructs are accepted, and -.Nm -makes no claim to emulate other compilers. But to the extent that a -feature is popular but nonstandard, this option provides a way to -support it, or add it. . .It Fl include Ar filename Process @@ -361,7 +453,6 @@ The should return a zero exit status, indicating success. If it returns a nonzero exit status, an error is reported and the compiler is not invoked. -. .It Fl fflex-debug Ns Li , Fl fyacc-debug produce messages useful for compiler development. The .Fl fflex-debug @@ -369,6 +460,111 @@ option prints the tokenized input stream. The .Fl fyacc-debug option shows the shift and reduce actions taken by the parser. .El +.Ss Diagnostic Messages +.Pp +Many warning options can be used to convert error messages to +warnings, or to suppress messages related to \*[lang] dialects. The +user may mix and match. A group of features may be enabled by +indicating a dialect (or more than one dialect) and individual +features may be enabled as a warning, or error, or suppressed. +.Bl -tag -width Wno-cdf-name-not-found\0\0 -compact +.It Fl Wno-apply-commit +Warn if APPLY COMMIT is used. +.It Fl Wno-bad-line-directive +Warn if malformed %<#line%> directive is encountered. +.It Fl Wno-binary-long-long +Warn if BINARY-LONG-LONG is used. +.It Fl Wno-call_giving +Warn if CALL ... GIVING is used. +.It Fl Wno-cdf-dollar +Warn if CDF \[Do]IF is used. +.It Fl Wno-comp-6 +Warn if COMPUTATIONAL-6 is used. +.It Fl Wno-comp-x +Warn if COMPUTATIONAL is used with PICTURE X. +.It Fl Wno-file-code-set +Warn if FILE CODE SET is used. +.It Fl Wno-inspect-trailing +Warn if INSPECT ... TRAILING is used. +.It Fl Wno-level-1-occurs +Warn if Level 01 is used with OCCURS. +.It Fl Wno-level-78-defined +Warn if CDF defines Level 78 constant. +.It Fl Wno-move-pointer +Warn if MOVE POINTER is used. +.It Fl Wno-returning-number +Warn if RETURNING <number> is used. +.It Fl Wno-usage-typename +Warn if USAGE IS TYPENAME is used. +.It Fl Wno-bad-numeric +Warn if numeric string is invalid. +.It Fl Wno-cdf-invalid-parameter +Warn if referenced CDF PARAMETER is not defined. +.It Fl Wno-cdf-name-not-found +Warn if referenced CDF name is not defined. +.It Fl Wno-cobol-eject +Warn if IBM-style EJECT is used (instead of error). +.It Fl Wno-cobol-resume +Warn if ISO RESUME is used with \-dialect ibm (instead of error). +.It Fl Wno-cobol-volatile +Warn if VOLATILE is used (instead of error if -dialect ibm). +.It Fl Wno-copybook-found +Print message when copybook is processed. +.It Fl Wno-ec-unknown +Warn if unimplemented/unknown exception condition is referenced. +.It Fl Wno-entry-convention +Print message when ENTRY CONVENTION is specified. +.It Fl Wno-high-order-bit +Warn if HIGH-ORDER-LEFT HIGH-ORDER-RIGHT is used. +.It Fl Wno-include-file-found +Print message when include file is processed. +.It Fl Wno-length-of +Warn if LENGTH OF is used. +.It Fl Wno-level-78 +Warn if Level 78 is used. +.It Fl Wno-literal-concat +Warn if concatenated literals use different encodings. +.It Fl Wno-locale-error +Warn if locale(3) fails. +.It Fl Wno-move-corresponding +Warn if COBOL MOVE has no corresponding fields. +.It Fl Wno-nllanginfo-error +Warn if nlanglanginfo(3) fails. +.It Fl Wno-recording-mode +Warn if RECORDING MODE is used. +.It Fl Wno-segment +Warn if SECTION segments are used. +.It Fl Wno-set-locale-to +Warn if SET LOCALE ... TO is used. +.It Fl Wno-set-to-locale +Warn if SET ... TO LOCALE is used. +. +`.\" convert errors to warnings +Warn if a line directive is malformed (instead of error). +.It Fl Wno-iconv-error +Warn if iconv(3) cannot convert between encodings (instead of error). +.It Fl Wno-include-file-not-found +Warn if include file is not found (instead of error). +.It Fl Wno-operator-space +Warn if relational operator not followed by space (instead of error). +.It Fl Wno-preprocessor-error +Warn if a preprocessor fails (instead of error). +.It Fl Wno-procedure-pointer +Warn if PROCEDURE POINTER is used. +.It Fl Wno-procedure-not-found +Warn if a referenced procedure is not found (instead of error). +.It Fl Wno-replace-error +Warn if REPLACE cannot be processed (instead of error). +.It Fl Wno-segment-error +Warn if a SEGMENT section is invalid (instead of error). +.It Fl Wno-segment-negative +Warn if a SEGMENT range is negative (instead of error). +.It Fl Wno-stop-number +Warn if IBM-style STOP <number> is used (instead of error). +.It Fl Wno-stray-indicator +Warn if indicator column has no recognized meaning (instead of error). + +.El . .Sh COMPILATION SCENARIOS .D1 gcobol Ar xyz.cob @@ -577,6 +773,21 @@ statement, regardless of compile-time constants. .. . .Ss Implemented Exception Conditions +By default, per ISO, no EC is enabled. Implemented ECs may be enabled +on the command line or via the +.Sy TURN +directive. Any attempt to enable an EC that is not implemented is +treated as an error. +.Pp +An enabled EC not handled by a +.Sy DECLARATIVE +is written to the system log and to standard error. (The authors +intend to make that an option.) A fatal EC not handled with +.Sy RESUME +ends with a call to +.Xr abort 3 +and process termination. +.Pp Not all Exception Conditions are implemented. Any attempt to enable an EC that that is not implemented produces a warning message. The following are implemented: @@ -753,6 +964,30 @@ resolution of .Ar filename is deferred until runtime, when the name must appear in the program's environment. +.Ss XML PARSE +.Nm +emulates the IBM +.Sy "XML PARSE" +statement. The following values for +.Sy XML-EVENT +are defined: +.Bl -tag -compact +.It Sy COMMENT +Text of a comment between "<!--" and "-->" +.It Sy CONTENT-CHARACTERS +Some or all of the character content of the element between start and end tags. +.It Sy END-OF-ELEMENT +End-element tag, with name if present in the input. +.It Sy PROCESSING-INSTRUCTION-DATA +Processing instruction (after the target name), excluding "?>". +.It Sy PROCESSING-INSTRUCTION-TARGET +The processing instruction target name appears in +.Sy XML-TEXT +or +.Sy XML-NTEXT . +.It Sy START-OF-ELEMENT +Name of the start element tag or empty element tag. +.El . .Sh ISO \*[lang] Implementation Status .Ss USAGE Data Types @@ -903,11 +1138,90 @@ or has no effect; the two are interchangeable. .. . -.Ss Compiler-Directing Facility (CDF) +.Sh COMPILER-DIRECTING FACILITY The CDF should be used with caution because no comprehensive test -suite has been identified. +suite has been identified. +. +.Ss CDF Text Manipulation +.Bl -tag -width >>DEFINE +.It Sy COPY Ar copybook Li Oo OF|BY Ar library Oc Oo Sy REPLACING ... Oc +If +.Ar copybook +is a literal, it treated a literal filename, which either does or does not exist. If +.Ar copybook +is a \*[lang] word, +.Nm +looks first for an environment variable named +.Va copybook +and, if found, uses the contents of that variable as the name of the +copybook file. If that file does not exist, it continues looking for +a file named one of: +.sp +.Bl -bullet -compact -offset 5n +.It +.Pa copybook +(literally) +.It +.Pa copybook.cpy +.It +.Pa copybook.CPY +.It +.Pa copybook.cbl +.It +.Pa copybook.CBL +.It +.Pa copybook.cob +.It +.Pa copybook.COB +.El +.sp +in that order. It looks first in the same directory as the source +code file, and then in any +.Ar copybook-path +named with the +.Fl I +option. +. +.\" FIXME: need escape mechanism for directories with ':' in the name. +.Ar copybook-path +may (like the shell's +.Ev PATH +variable) be a colon-separated list. +The +.Fl I +option may occur multiple times on the command line. Each successive +.Ar copybook-path +is concatenated to previous ones. +Relative paths (having no leading +.Ql / Ns +\&) +are searched relative to the compiler's current working directory. +.Pp +For example, +.D1 \& +.D1 Fl I Li /usr/local/include:include +.D1 \& +searches first the directory where the \*[lang] program is found, next in +.Pa /usr/local/include , +and finally in an +.Pa include +subdirectory of the directory from which +.Nm +was invoked. +.Pp +For the +.Sy REPLACING +phrase, both the modern pseudo-text and the \*[lang]/85 forms are +recognized. (The older forms are used in the NIST CCVS/85 test suite.) +.It Sy REPLACE ... +.Nm +supports the full ISO +.Sy REPLACE +syntax. +.El . -.Ss Conditional Compilation +.Ss CDF Directives +.\"Bl -tag -width >>PROPAGATE .Bl -tag -width >>DEFINE .It >> Ns Sy DEFINE Ar name Sy AS Bro Ar expression Li | Sy PARAMETER Brc Op Sy OVERRIDE Define @@ -949,10 +1263,6 @@ is supported. Boolean literals are not supported. . .It >> Ns Sy EVALUATE Not implemented. -.El -. -.Ss Other CDF Directives -.Bl -tag -width >>PROPAGATE .It >> Ns Sy CALL-CONVENTION Ar convention .Ar convention may be one of: @@ -1000,9 +1310,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 @@ -1023,6 +1336,24 @@ Not implemented. Not implemented. .It >> Ns Sy PROPAGATE Not implemented. +.It >> Ns Sy PUSH Ar directive +.It >> Ns Sy POP Ar directive +With +.Sy PUSH , +push CDF state onto a stack. +With +.Sy POP , +return to the prior pushed state. +.Ar directive +may be one of +.Bl -tag -compact +.It Sy CALL-CONVENTION +.It Sy COBOL-WORDS +.It Sy DEFINE +.It Sy SOURCE FORMAT +.It Sy TURN +.El +. .It >> Ns Sy TURN Oo .Ar ec Oo Ar file Li ... Oc ... .Oc Sy CHECKING Bro Oo Sy ON Oc Oo Oo Sy WITH Oc Sy LOCATION Oc | Sy OFF Brc @@ -1073,76 +1404,6 @@ the directive must appear before .Pp To test a feature-set variable, use .Dl >>IF Ar feature Li DEFINED -.. -.Ss Copybooks -.Nm -supports the CDF -.Sy COPY -statement, with or without its -.Sy REPLACING -component. For any statement -.sp -.D1 COPY Ar copybook -.sp -.Nm -looks first for an environment variable named -.Va copybook -and, if found, uses the contents of that variable as the name of the -copybook file. If that file does not exist, it continues looking for -a file named one of: -.sp -.Bl -bullet -compact -offset 5n -.It -.Pa copybook -(literally) -.It -.Pa copybook.cpy -.It -.Pa copybook.CPY -.It -.Pa copybook.cbl -.It -.Pa copybook.CBL -.It -.Pa copybook.cob -.It -.Pa copybook.COB -.El -.sp -in that order. It looks first in the same directory as the source -code file, and then in any -.Ar copybook-path -named with the -.Fl I -option. -. -.\" FIXME: need escape mechanism for directories with ':' in the name. -.Ar copybook-path -may (like the shell's -.Ev PATH -variable) be a colon-separated list. -. -The -.Fl I -option may occur multiple times on the command line. Each successive -.Ar copybook-path -is concatenated to previous ones. -Relative paths (having no leading -.Ql / Ns -\&) -are searched relative to the compiler's current working directory. -.Pp -For example, -.D1 \& -.D1 Fl I Li /usr/local/include:include -.D1 \& -searches first the directory where the \*[lang] program is found, next in -.Pa /usr/local/include , -and finally in an -.Pa include -subdirectory of the directory from which -.Nm -was invoked. . .Ss Intrinsic functions .Nm @@ -1152,54 +1413,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 +1540,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 +1571,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 +1607,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. @@ -1366,6 +1627,15 @@ it may contain several directory names separated by a colon .Ev COBPATH is searched first, followed by .Ev LD_LIBRARY_PATH . +Note that +.Ev COBPATH does not change where the runtime linker looks for +.Pa libgcobol.so +itself. +How the runtime linker searches for +.Pa libgcobol.so +when the executable loads is controlled by +.Xr ld.so 8 , +not libgcobol. .Pp Each directory is searched for files whose name ends in .Ql ".so" . @@ -1420,6 +1690,18 @@ error. This feature is meant to help diagnose mysterious copybook errors. .El . +.Ss Variables for Developers +.Bl -tag -compact +.It Ev GCOBOL_SHOW +produces a trace of the internal calls made by the parser to prepare +the GENERIC tree. +.It Ev GCOBOL_TRACE +used at compile time, produces an executable that traces the +execution, mapping it back the same code-creation functions as +.Ev GCOBOL_SHOW , +as well as the values of data items and branch conditions. +.El +. .Sh FILES Executables produced by .Nm diff --git a/gcc/cobol/gcobolspec.cc b/gcc/cobol/gcobolspec.cc index 4ae8e2c..1f1b463 100644 --- a/gcc/cobol/gcobolspec.cc +++ b/gcc/cobol/gcobolspec.cc @@ -57,10 +57,6 @@ along with GCC; see the file COPYING3. If not see int lang_specific_extra_outfiles = 0; -#ifndef MATH_LIBRARY -#define MATH_LIBRARY "m" -#endif - #ifndef DL_LIBRARY #define DL_LIBRARY "dl" #endif @@ -73,16 +69,20 @@ int lang_specific_extra_outfiles = 0; #define COBOL_LIBRARY "gcobol" #endif +#define SPEC_FILE "libgcobol.spec" + /* The original argument list and related info is copied here. */ static const struct cl_decoded_option *original_options; /* The new argument list will be built here. */ static std::vector<cl_decoded_option>new_opt; +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; @@ -116,8 +116,8 @@ add_arg_lib(const char *library, bool force_static ATTRIBUTE_UNUSED) { append_option (OPT_Wl_, LD_STATIC_OPTION, 1); } - append_option (OPT_l, library, 1); #endif + append_option (OPT_l, library, 1); #ifdef HAVE_LD_STATIC_DYNAMIC if( force_static ) { @@ -126,41 +126,6 @@ add_arg_lib(const char *library, bool force_static ATTRIBUTE_UNUSED) #endif } -static void -append_rdynamic() - { - // This is a bit ham-handed, but I was in a hurry. - struct cl_decoded_option decoded = {}; - decoded.opt_index = OPT_rdynamic; - decoded.orig_option_with_args_text = "-rdynamic"; - decoded.canonical_option[0] = "-rdynamic"; - decoded.canonical_option_num_elements = 1; - decoded.value = 1; - append_arg(decoded); - return; - } - -static void -append_allow_multiple_definition() - { - append_option (OPT_Wl_, "--allow-multiple-definition", 1); - return; - } - -static void -append_fpic() - { - // This is a bit ham-handed, but I was in a hurry. - struct cl_decoded_option decoded = {}; - decoded.opt_index = OPT_rdynamic; - decoded.orig_option_with_args_text = "-fPIC"; - decoded.canonical_option[0] = "-fPIC"; - decoded.canonical_option_num_elements = 1; - decoded.value = 1; - append_arg(decoded); - return; - } - void lang_specific_driver (struct cl_decoded_option **in_decoded_options, unsigned int *in_decoded_options_count, @@ -177,9 +142,6 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, int n_infiles = 0; int n_outfiles = 0; - // The number of input files when the language is "none" or "cobol" - int n_cobol_files = 0; - // saw_OPT_no_main means "don't expect -main" bool saw_OPT_no_main = false; @@ -188,20 +150,13 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, bool saw_OPT_c = false; bool saw_OPT_shared = false; - bool saw_OPT_pic = false; - bool saw_OPT_PIC = false; bool verbose = false; // These flags indicate whether we need various libraries - bool need_libgcobol = true; - bool need_libmath = (MATH_LIBRARY[0] != '\0'); bool need_libdl = (DL_LIBRARY[0] != '\0'); bool need_libstdc = (STDCPP_LIBRARY[0] != '\0'); - // bool need_libquadmath = (QUADMATH_LIBRARY[0] != '\0'); - bool need_rdynamic = true; - bool need_allow_multiple_definition = true; // Separate flags for a couple of static libraries bool static_libgcobol = false; @@ -276,11 +231,6 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, case OPT_SPECIAL_input_file: no_files_error = false; n_infiles += 1; - if( strcmp(language, "none") == 0 - || strcmp(language, "cobol") == 0 ) - { - n_cobol_files += 1; - } if( strstr(decoded_options[i].orig_option_with_args_text, "libgcobol.a") ) { // We have been given an explicit libgcobol.a. We need to note that. @@ -292,37 +242,10 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, saw_OPT_shared = true; break; - case OPT_fpic: - saw_OPT_pic = true; - break; - - case OPT_fPIC: - saw_OPT_PIC = true; - break; - - case OPT_c: - // With this option, no libraries need be loaded + case OPT_c: + // Note -c specially. saw_OPT_c = true; - need_libgcobol = false; - need_libmath = false; - need_libdl = false; - need_libstdc = false; - // need_libquadmath = false; - need_rdynamic = false; - break; - - case OPT_rdynamic: - need_rdynamic = false; - break; - - case OPT_Wl_: - if( strstr(decoded_options[i].orig_option_with_args_text, - "--allow-multiple-definitions") ) - { - need_allow_multiple_definition = false; - } - break; - + // FALLTHROUGH case OPT_nostdlib: case OPT_nodefaultlibs: case OPT_r: @@ -331,27 +254,18 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, case OPT_E: // With these options, no libraries need be loaded need_libgcobol = false; - need_libmath = false; need_libdl = false; need_libstdc = false; - // need_libquadmath = false; - need_rdynamic = false; break; case OPT_static_libgcobol: -#ifdef HAVE_LD_STATIC_DYNAMIC static_libgcobol = true; need_libgcobol = true; -#endif break; case OPT_l: n_infiles += 1; - if(strcmp(decoded_options[i].arg, MATH_LIBRARY) == 0) - { - need_libmath = false; - } - else if(strcmp(decoded_options[i].arg, DL_LIBRARY) == 0) + if(strcmp(decoded_options[i].arg, DL_LIBRARY) == 0) { need_libdl = false; } @@ -387,8 +301,8 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, case OPT_print_multi_os_directory: case OPT_print_multiarch: case OPT_print_sysroot_headers_suffix: - no_files_error = false; - break; + no_files_error = false; + break; case OPT_v: no_files_error = false; @@ -457,10 +371,8 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, if( n_infiles == 0 ) { need_libgcobol = false; - need_libmath = false; need_libdl = false; need_libstdc = false; - // need_libquadmath = false; } /* Second pass through arglist, transforming arguments as appropriate. */ @@ -500,15 +412,11 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, if( prior_main ) { - char ach[128]; - if( entry_point ) - { - strcpy(ach, entry_point); - } + const char *ach; + if (entry_point) + ach = entry_point; else - { - strcpy(ach, decoded_options[i].arg); - } + ach = decoded_options[i].arg; append_option(OPT_main_, ach, 1); prior_main = false; entry_point = NULL; @@ -548,7 +456,11 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, break; case OPT_static_libgcobol: - // Don't pass this one on to cobol1 +#if !defined (HAVE_LD_STATIC_DYNAMIC) + // Allow the target to use spec substitution. + append_arg(decoded_options[i]); +#endif + // Else don't pass this one on to cobol1 break; ////#ifdef __x86_64__ @@ -558,7 +470,10 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, //// break; ////#endif case OPT_static: +#if defined (HAVE_LD_STATIC_DYNAMIC) + append_arg(decoded_options[i]); static_in_general = true; +#endif break; default: @@ -586,36 +501,23 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, need_libgcobol = false; } - if( need_libgcobol ) + if( static_in_general ) { - add_arg_lib(COBOL_LIBRARY, static_libgcobol); - } - if( need_libmath) - { - add_arg_lib(MATH_LIBRARY, static_in_general); - } - if( need_libdl ) - { - add_arg_lib(DL_LIBRARY, static_in_general); - } - if( need_libstdc && static_in_general ) - { - add_arg_lib(STDCPP_LIBRARY, static_in_general); + // These two options interfere with each other. + static_libgcobol = false; } - if( saw_OPT_shared && !saw_OPT_pic && !saw_OPT_PIC ) + if( need_libgcobol ) { - append_fpic(); + add_arg_lib(COBOL_LIBRARY, static_libgcobol); } - - if( need_rdynamic ) + if( need_libdl ) { - append_rdynamic(); + add_arg_lib(DL_LIBRARY, false); } - - if( need_allow_multiple_definition && (n_infiles || n_outfiles) ) + if( need_libstdc ) { - append_allow_multiple_definition(); + add_arg_lib(STDCPP_LIBRARY, false); } if( prior_main ) @@ -628,7 +530,8 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, // cl_decoded_option size_t new_option_count = new_opt.size(); - struct cl_decoded_option *new_options = XNEWVEC (struct cl_decoded_option, new_option_count); + struct cl_decoded_option *new_options = XNEWVEC (struct cl_decoded_option, + new_option_count); for(size_t i=0; i<new_option_count; i++) { @@ -638,15 +541,16 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, #ifdef NOISY verbose = true; #endif - if( verbose && new_options != original_options ) + if( verbose && new_options != original_options ) // cppcheck-suppress knownConditionTrueFalse { - fprintf(stderr, _("Driving: (%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"); @@ -656,14 +560,12 @@ lang_specific_driver (struct cl_decoded_option **in_decoded_options, *in_decoded_options = new_options; } -/* - * Called before linking. - * Returns 0 on success and -1 on failure. - * Unused. - */ +/* Called before linking. Returns 0 on success and -1 on failure. */ int -lang_specific_pre_link( void ) - { - return 0; - } +lang_specific_pre_link (void) +{ + if (need_libgcobol) + do_spec ("%:include(libgcobol.spec)"); + return 0; +} diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index a4abbd1..ee325fc 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -27,6 +27,7 @@ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ + #include "cobol-system.h" #include "coretypes.h" @@ -34,8 +35,7 @@ #include "tree-iterator.h" #include "stringpool.h" #include "diagnostic-core.h" - -#define HOWEVER_GCC_DEFINES_TREE 1 +#include "target.h" #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" @@ -50,17 +50,19 @@ #include "genmath.h" #include "structs.h" #include "../../libgcobol/gcobolio.h" -#include "../../libgcobol/libgcobol.h" #include "../../libgcobol/charmaps.h" #include "../../libgcobol/valconv.h" #include "show_parse.h" +#include "fold-const.h" +#include "realmpfr.h" 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; @@ -76,10 +78,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 @@ -114,17 +118,17 @@ typedef struct TREEPLET static void -treeplet_fill_source(TREEPLET &treeplet, cbl_refer_t &refer) +treeplet_fill_source(TREEPLET &treeplet, const cbl_refer_t &refer) { treeplet.pfield = gg_get_address_of(refer.field->var_decl_node); - treeplet.offset = refer_offset_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); } @@ -140,9 +144,9 @@ static void move_helper(tree size_error, // INT // set using -f-trace-debug, defined in lang.opt int f_trace_debug; -// When doing WRITE statements, the IBM Language Reference and the ISO/IEC_2014 -// standard specify that when the ADVANCING clause is omitted, the default is -// AFTER ADVANCING 1 LINE. +// When doing WRITE statements, the IBM Language Reference and the +// ISO/IEC_2014 standard specify that when the ADVANCING clause is omitted, the +// default isAFTER ADVANCING 1 LINE. // // MicroFocus and GnuCOBOL state that the default is BEFORE ADVANCING 1 LINE // @@ -187,6 +191,9 @@ const char *gv_trace_switch = NULL; char const *bTRACE1 = NULL; tree trace_handle; tree trace_indent; + +// This variable is set to true when the output cursor is known to be at the +// start-of-line. bool cursor_at_sol = true; static void @@ -196,10 +203,10 @@ trace1_init() if( first_time ) { first_time = false; - trace_handle = gg_define_variable(INT, "trace_handle", vs_static); - trace_indent = gg_define_variable(INT, "trace_indent", vs_static); + 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 ) { @@ -226,6 +233,13 @@ trace1_init() } } +static +void +insert_nop(int n) + { + gg_assign(var_decl_nop, build_int_cst_type(INT, n)); + } + static void create_cblc_string_variable(const char *var_name, const char *var_contents) { @@ -263,13 +277,22 @@ build_main_that_calls_something(const char *something) SHOW_PARSE_END } - gg_set_current_line_number(DEFAULT_LINE_NUMBER); + tree function_decl = gg_define_function( INT, + "main", + "main", + INT, "argc", + build_pointer_type(CHAR_P), "argv", + NULL_TREE); - gg_define_function( INT, - "main", - INT, "argc", - build_pointer_type(CHAR_P), "argv", - NULL_TREE); + // Modify the default settings for main(), as empirically determined from + // examining C/C+_+ compilations. (See the comment for gg_build_fn_decl()). + TREE_ADDRESSABLE(function_decl) = 0; + TREE_USED(function_decl) = 0; + TREE_NOTHROW(function_decl) = 0; + TREE_STATIC(function_decl) = 1; + DECL_EXTERNAL (function_decl) = 0; + TREE_PUBLIC (function_decl) = 1; + DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 1; // Pick up pointers to the input parameters: // First is the INT which is the number of argv[] entries @@ -307,7 +330,6 @@ build_main_that_calls_something(const char *something) argc, argv, NULL_TREE))); - strncpy(ach_cobol_entry_point, psz, sizeof(ach_cobol_entry_point)-1); free(psz); gg_finalize_function(); } @@ -344,11 +366,15 @@ static char * level_88_helper(size_t parent_capacity, const cbl_domain_elem_t &elem, - size_t &returned_size) + size_t &returned_size, + cbl_encoding_t encoding) { // We return a MALLOCed return value, which the caller must free. - char *retval = (char *)xmalloc(parent_capacity + 64); - char *builder = (char *)xmalloc(parent_capacity + 64); + char *retval = static_cast<char *>(xmalloc(parent_capacity + 64)); + gcc_assert(retval); + char *builder = static_cast<char *>(xmalloc(parent_capacity + 64)); + gcc_assert(builder); + size_t nbuild = 0; cbl_figconst_t figconst = cbl_figconst_of( elem.name()); @@ -389,15 +415,25 @@ level_88_helper(size_t parent_capacity, // Pick up the string size_t first_name_length = elem.size(); - char *first_name = (char *)xmalloc(first_name_length + 1); + char *first_name = static_cast<char *>(xmalloc(first_name_length + 1)); + gcc_assert(first_name); memcpy(first_name, elem.name(), first_name_length); first_name[first_name_length] = '\0'; - // Convert it to EBCDIC, when necessary; leave it alone when not necessary. - for(size_t i=0; i<first_name_length; i++) + /* By rights, the parser should have given us this string in the target + encoding. When I discovered that it was not, Jim Lowden was out of + town for a week, and I didn't feel like figuring out where in the + parser the fix should be. + + So, I am doing the conversion here. Eventually that will be fixed, and + chaos will reign here. When that happens, remove the following + conversion. */ + charmap_t *charmap = __gg__get_charmap(encoding); + for(size_t i=0; i<strlen(first_name); i++) { - first_name[i] = ascii_to_internal(first_name[i]); + first_name[i] = charmap->mapped_character(first_name[i]); } + ///////////////// end of conversion if( parent_capacity == 0 ) { @@ -427,7 +463,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); @@ -465,7 +502,7 @@ get_level_88_domain(size_t parent_capacity, cbl_field_t *var, size_t &returned_s // Numerics are converted to strings, and handled as above size_t retval_capacity = 64; - char *retval = (char *)xmalloc(retval_capacity); + char *retval = static_cast<char *>(xmalloc(retval_capacity)); size_t output_index = 0; // Loop through the provided domains: @@ -478,30 +515,46 @@ get_level_88_domain(size_t parent_capacity, cbl_field_t *var, size_t &returned_s char *stream; // Do the first element of the domain - stream = level_88_helper(parent_capacity, domain->first, stream_len); + stream = level_88_helper( parent_capacity, + domain->first, + stream_len, + var->codeset.encoding); if( output_index + stream_len > retval_capacity ) { retval_capacity *= 2; - retval = (char *)xrealloc(retval, retval_capacity); + retval = static_cast<char *>(xrealloc(retval, retval_capacity)); } + gcc_assert(retval); memcpy(retval + output_index, stream, stream_len); output_index += stream_len; returned_size += stream_len; free(stream); // Do the second element of the domain - stream = level_88_helper(parent_capacity, domain->last, stream_len); + stream = level_88_helper( parent_capacity, + domain->last, + stream_len, + var->codeset.encoding); if( output_index + stream_len > retval_capacity ) { retval_capacity *= 2; - retval = (char *)xrealloc(retval, retval_capacity); + retval = static_cast<char *>(xrealloc(retval, retval_capacity)); } + gcc_assert(retval); memcpy(retval + output_index, stream, stream_len); output_index += stream_len; returned_size += stream_len; free(stream); domain += 1; } + + if( returned_size >= retval_capacity) + { + retval_capacity *= 2; + retval = static_cast<char *>(xrealloc(retval, retval_capacity)); + } + + gcc_assert(returned_size < retval_capacity); retval[returned_size++] = '\0'; return retval; } @@ -554,21 +607,15 @@ get_class_condition_string(cbl_field_t *var) uint8_t value1; uint8_t value2; - char achFirstName[256]; - char achLastName[256]; - size_t first_name_length = domain->first.size() ? domain->first.size() : strlen(domain->first.name()); - size_t last_name_length = domain->last.size() - ? domain->last.size() - : strlen(domain->last.name()); if( domain->first.is_numeric ) { 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 @@ -592,26 +639,11 @@ get_class_condition_string(cbl_field_t *var) { // Since the first.name is a single character, we can do this as // a single-character pair. + uint8_t ch1; + uint8_t ch2; - // Keep in mind that the single character might be a two-byte UTF-8 - // codepoint - uint8_t ch1 = domain->first.name()[0]; - uint8_t ch2 = domain->last.name()[0]; - - gcc_assert(first_name_length <= 2); - gcc_assert(last_name_length <= 2); - - char *p2; - size_t one; - p2 = achFirstName; - one = 8; - raw_to_internal(&p2, &one, domain->last.name(), last_name_length); - ch2 = achFirstName[0]; - - p2 = achLastName; - one = 8; - raw_to_internal(&p2, &one, domain->first.name(), first_name_length); - ch1 = achLastName[0]; + ch2 = domain->last.name()[0]; + ch1 = domain->first.name()[0]; if( ch1 < ch2 ) { @@ -638,15 +670,12 @@ get_class_condition_string(cbl_field_t *var) // We are working with a string larger than 1 character. The COBOL // spec says there can't be a THROUGH, so we ignore the last.name: - char *p2; - size_t one; - p2 = achFirstName; - one = 8; - raw_to_internal(&p2, &one, domain->last.name(), last_name_length); - + // size_t first_name_length = domain->first.size() + // ? domain->first.size() + // : strlen(domain->first.name()); for(size_t i=0; i<first_name_length; i++) { - p += sprintf(p, "%2.2X ", (unsigned char)achFirstName[i]); + p += sprintf(p, "%2.2X ", (unsigned char)domain->first.name()[i]); } } domain += 1; @@ -691,30 +720,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); } /* @@ -726,28 +767,37 @@ 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 " NOT dumping", + (fmt_size_t)current_program_index() ); +#if 0 // A change to call_targets rendered this routine useless. Until we get + // around to repairing it, this code is left for reference. for( const auto& elem : call_targets ) { const auto& k = elem.first; const auto& v = elem.second; - 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"); } +#endif } size_t @@ -755,21 +805,28 @@ parser_call_target_update( size_t caller, const char plain_name[], const char mangled_name[] ) { - auto key = program_reference_t(caller, plain_name); - auto p = call_targets.find(key); - if( p == call_targets.end() ) return 0; + auto key = program_reference_t(caller, plain_name); + auto p = call_targets.find(key); + if( p == call_targets.end() ) return 0; - for( auto func : p->second ) - { - func.convention = cbl_call_verbatim_e; - DECL_NAME(func.node) = get_identifier(mangled_name); - } - return p->second.size(); + for( auto call_expr : p->second ) + { + tree fndecl_type = build_varargs_function_type_array( COBOL_FUNCTION_RETURN_TYPE, + 0, // No parameters yet + NULL); // And, hence, no types + + // Fetch the FUNCTION_DECL for that FUNCTION_TYPE + tree function_decl = gg_build_fn_decl(mangled_name, fndecl_type); + tree function_address = gg_get_address_of(function_decl); + + TREE_OPERAND(call_expr, 1) = function_address; + } + return p->second.size(); } static tree -function_handle_from_name(cbl_refer_t &name, - tree function_return_type) +function_pointer_from_name(const cbl_refer_t &name, + tree function_return_type) { Analyze(); @@ -777,74 +834,80 @@ 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"), - build_int_cst_type(SIZE_T, sizeof(void *))); + sizeof_pointer); } else { - gg_memcpy(gg_get_address_of(function_handle), - qualified_data_source(name), - build_int_cst_type(SIZE_T, sizeof(void *))); + gg_memcpy(gg_get_address_of(function_pointer), + qualified_data_location(name), + sizeof_pointer); } - return function_handle; + return function_pointer; } else if( use_static_call() && is_literal(name.field) ) { - // It's a literal, and we are using static calls. Generate the CALL, and - // pass the address expression to parser_call_target(). That will cause - // parser_call_target_update() to replace any nested CALL "foo" with the - // local "foo.60" name. - - // We create a reference to it, which is later resolved by the linker. - tree addr_expr = gg_get_function_address( function_return_type, - name.field->data.initial); - gg_assign(function_handle, addr_expr); - - tree func = TREE_OPERAND(addr_expr, 0); - parser_call_target(func); // add function to list of call targets + tree fndecl_type = build_varargs_function_type_array( function_return_type, + 0, // No parameters yet + NULL); // And, hence, no types + + // Fetch the FUNCTION_DECL for that FUNCTION_TYPE + char *tname = static_cast<char *>(xmalloc(name.field->data.capacity+1)); + memcpy(tname, name.field->data.original(), name.field->data.capacity); + tname[name.field->data.capacity] = '\0'; + tree function_decl = gg_build_fn_decl(tname, + fndecl_type); + free(tname); + // 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.original()), + 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 -parser_initialize_programs(size_t nprogs, struct cbl_refer_t *progs) +parser_initialize_programs( size_t nprogs, + const struct cbl_refer_t *progs) { Analyze(); SHOW_PARSE @@ -860,7 +923,7 @@ parser_initialize_programs(size_t nprogs, struct cbl_refer_t *progs) if( progs[i].field->type == FldLiteralA ) { SHOW_PARSE_TEXT("\"") - SHOW_PARSE_TEXT(progs[i].field->data.initial) + SHOW_PARSE_TEXT(progs[i].field->data.original()) SHOW_PARSE_TEXT("\"") } else @@ -874,40 +937,272 @@ 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[64]; + static int counter = 1; + sprintf(ach, "_ecs_table_%d", counter++); + tree retval = array_of_long_long(ach, ecs); + SHOW_IF_PARSE(nullptr) + { + SHOW_PARSE_HEADER + 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 + 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[64]; + static int counter = 1; + sprintf(ach, "_dcls_table_%d", counter++); + tree retval = array_of_long_long(ach, dcls); + SHOW_IF_PARSE(nullptr) + { + SHOW_PARSE_HEADER + 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 + 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: - if( gg_get_current_line_number() == DEFAULT_LINE_NUMBER ) + static const std::set<std::string> file_ops = { - // This code is prevents anomolies 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)); + "OPEN", + "CLOSE", + "READ", + "WRITE", + "DELETE", + "REWRITE", + "START", + }; + + // Performance note: By doing exception processing only when necessary + // the execution time of a program doing two-billion simple adds in an inner + // loop dropped from 3.8 seconds to 0.175 seconds. + + bool exception_processing = cdf_enabled_exceptions().size() ; + + if( !exception_processing ) + { + exception_processing = file_ops.find(statement_name) != file_ops.end(); } - gg_set_current_line_number(CURRENT_LINE_NUMBER); + // At this point, if any exception is enabled, we store the location stuff. + // Each file I-O routine calls store_location_stuff explicitly, because + // those exceptions can't be defeated. + + if( exception_processing ) + { + store_location_stuff(statement_name); + set_exception_environment(ecs, dcls); + } + + sv_is_i_o = false; } static void @@ -920,10 +1215,9 @@ initialize_variable_internal( cbl_refer_t refer, // gg_string_literal(refer.field->name), // NULL_TREE); cbl_field_t *parsed_var = refer.field; - - if( parsed_var->type == FldLiteralA ) + if( !parsed_var ) { - return; + cbl_internal_error("%s should not be null", "parsed_var"); } if( parsed_var->is_key_name() ) @@ -934,12 +1228,7 @@ initialize_variable_internal( cbl_refer_t refer, return; } - if( is_register_field( parsed_var) ) - { - return; - } - - if( parsed_var && parsed_var->type == FldBlob ) + if( parsed_var->attr & register_e ) { return; } @@ -1043,7 +1332,9 @@ initialize_variable_internal( cbl_refer_t refer, default: { char ach[128]; - strfromf128(ach, sizeof(ach), "%.16E", parsed_var->data.value_of()); + real_to_decimal (ach, + TREE_REAL_CST_PTR (parsed_var->data.value_of()), + sizeof(ach), 16, 0); SHOW_PARSE_TEXT(ach); break; } @@ -1055,15 +1346,13 @@ initialize_variable_internal( cbl_refer_t refer, SHOW_PARSE_END } - CHECK_FIELD(parsed_var); - // When initializing a variable, we have to ignore any DEPENDING ON clause // that might otherwise apply suppress_dest_depends = true; bool is_redefined = false; - cbl_field_t *family_tree = parsed_var; + const cbl_field_t *family_tree = parsed_var; while(family_tree) { if( symbol_redefines(family_tree) ) @@ -1084,7 +1373,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 ) @@ -1114,7 +1403,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 @@ -1125,7 +1414,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); } @@ -1227,7 +1516,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 } @@ -1246,7 +1568,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 ) @@ -1263,7 +1585,7 @@ parser_initialize(cbl_refer_t refer, bool like_parser_symbol_add) static void get_binary_value_from_float(tree value, - cbl_refer_t &dest, + const cbl_refer_t &dest, cbl_field_t *source, tree source_offset ) @@ -1298,8 +1620,8 @@ get_binary_value_from_float(tree value, gg_assign(fvalue, gg_multiply(fvalue, gg_float(ftype, - build_int_cst_type(INT, - get_power_of_ten(rdigits))))); + wide_int_to_tree(INT, + get_power_of_ten(rdigits))))); // And we need to throw away any digits to the left of the leftmost digits: // At least, we need to do so in principl. I am deferring this problem until @@ -1337,48 +1659,29 @@ gg_attribute_bit_set(struct cbl_field_t *var, cbl_field_attr_t bits) } #pragma GCC diagnostic pop -static void -gg_default_qualification(struct cbl_field_t * /*var*/) - { -// gg_attribute_bit_clear(var, refmod_e); - } - -static void -gg_get_depending_on_value(tree depending_on, cbl_field_t *current_sizer) +static +void +depending_on_value(tree depending_on, cbl_field_t *current_sizer) { // We have to deal with the possibility of a DEPENDING_ON variable, // and we have to apply array bounds whether or not there is a DEPENDING_ON // variable: - tree occurs_lower = gg_define_variable(LONG, "_lower"); - tree occurs_upper = gg_define_variable(LONG, "_upper"); - - gg_assign(occurs_lower, build_int_cst_type(LONG, current_sizer->occurs.bounds.lower)); - gg_assign(occurs_upper, build_int_cst_type(LONG, current_sizer->occurs.bounds.upper)); +// tree occurs_lower = gg_define_variable(LONG, "_lower"); +// tree occurs_upper = gg_define_variable(LONG, "_upper"); +// +// gg_assign(occurs_lower, build_int_cst_type(LONG, current_sizer->occurs.bounds.lower)); +// gg_assign(occurs_upper, build_int_cst_type(LONG, current_sizer->occurs.bounds.upper)); + gcc_assert(current_sizer); if( current_sizer->occurs.depending_on ) { - // Get the current value of the depending_on data-item: - tree value = gg_define_int128(); - get_binary_value( value, - NULL, - cbl_field_of(symbol_at(current_sizer->occurs.depending_on)), - size_t_zero_node); - gg_assign(depending_on, gg_cast(LONG, value)); - IF( depending_on, lt_op, occurs_lower ) - // depending_is can be no less than occurs_lower: - gg_assign(depending_on, occurs_lower ); - ELSE - ENDIF - IF( depending_on, gt_op, occurs_upper ) - // depending_is can be no greater than occurs_upper: - gg_assign(depending_on, occurs_upper ); - ELSE - ENDIF + get_depending_on_value_from_odo(depending_on, current_sizer); } else { - gg_assign(depending_on, occurs_upper); + gg_assign(depending_on, + build_int_cst_type(LONG, current_sizer->occurs.bounds.upper)); } } @@ -1481,7 +1784,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 ); @@ -1514,16 +1817,12 @@ normal_normal_compare(bool debugging, NULL_TREE); } - bool needs_adjusting; if( !left_intermediate && !right_intermediate ) { // Yay! Both sides have fixed rdigit values. - // Flag needs_adjusting as false, because we are going to do it here: - needs_adjusting = false; int adjust = get_scaled_rdigits(left_side_ref->field) - get_scaled_rdigits(right_side_ref->field); - if( adjust > 0 ) { // We need to make right_side bigger to match the scale of left_side @@ -1538,6 +1837,7 @@ normal_normal_compare(bool debugging, else { // At least one side is right_intermediate + bool needs_adjusting; tree adjust; if( !left_intermediate && right_intermediate ) @@ -1774,8 +2074,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(); @@ -1785,13 +2085,14 @@ 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 ) { // left side is hi-value @@ -1948,23 +2249,27 @@ cobol_compare( tree return_int, case FldLiteralA: { // Comparing a FldLiteralN to an alphanumeric - // It is the case that data.initial is in the original form seen - // in the source code, which means that even in EBCDIC mode the - // characters are in the "ASCII" state. - - static size_t buffer_size = 0; - static char *buffer = NULL; - raw_to_internal(&buffer, - &buffer_size, - lefty->field->data.initial, - strlen(lefty->field->data.initial)); + // This next conversion may be overkill. But just in case + // the encodings of the two variables are different, we are + // going to convert left-side text to the right-side encoding + cbl_encoding_t enc_left = lefty->field->codeset.encoding; + cbl_encoding_t enc_right = righty->field->codeset.encoding; + size_t outlength; + size_t inlength = strlen(lefty->field->data.initial); + char *converted = __gg__iconverter( + enc_left, + enc_right, + lefty->field->data.initial, + inlength, + &outlength ); gg_assign( return_int, gg_call_expr( INT, "__gg__literaln_alpha_compare", - gg_string_literal(buffer), + build_string_literal(strlen(lefty->field->data.initial)+1, + converted), 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)), @@ -2027,34 +2332,38 @@ 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; // Commented out to quiet cppcheck } - -// gg_printf(" result is %d\n", return_int, NULL_TREE); } static void move_tree( cbl_field_t *dest, tree offset, - tree psz_source, - tree length_bump=integer_zero_node) // psz_source is a null-terminated string + tree psz_source, // psz_source is a null-terminated string + tree length_bump=integer_zero_node) { + // This routine assumes that the psz_source is in the same codeset as the + // dest. + Analyze(); SHOW_PARSE { @@ -2063,6 +2372,8 @@ move_tree( cbl_field_t *dest, SHOW_PARSE_END } + CHECK_FIELD(dest); + bool moved = true; tree source_length = gg_define_size_t(); @@ -2097,15 +2408,20 @@ move_tree( cbl_field_t *dest, { case FldGroup: case FldAlphanumeric: + { // Space out the alphanumeric destination: + charmap_t *charmap = __gg__get_charmap(dest->codeset.encoding); + gg_memset( location, - build_int_cst_type(INT, internal_space), + build_int_cst_type(INT, + charmap->mapped_character(ascii_space)), length ); // Copy the alphanumeric result over. gg_memcpy( location, psz_source, min_length ); break; + } case FldNumericDisplay: case FldNumericEdited: @@ -2119,8 +2435,9 @@ move_tree( cbl_field_t *dest, gg_assign(value, gg_call_expr( INT128, - "__gg__dirty_to_binary_internal", + "__gg__dirty_to_binary", psz_source, + build_int_cst_type(INT, dest->codeset.encoding), source_length, gg_get_address_of(rdigits), NULL_TREE)); @@ -2141,12 +2458,13 @@ move_tree( cbl_field_t *dest, case FldAlphaEdited: { gg_call(VOID, - "__gg__string_to_alpha_edited_ascii", + "__gg__string_to_alpha_edited", location, + build_int_cst_type(INT, DEFAULT_SOURCE_ENCODING), psz_source, min_length, member(dest->var_decl_node, "picture"), - NULL); + NULL_TREE); break; } @@ -2167,10 +2485,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; } @@ -2179,6 +2497,7 @@ move_tree( cbl_field_t *dest, static void move_tree_to_field(cbl_field_t *field, tree psz) { + // psz has to be in the same encoding as field move_tree(field, integer_zero_node, psz); } @@ -2201,7 +2520,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)); @@ -2236,7 +2555,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; } @@ -2249,12 +2568,12 @@ get_string_from(cbl_field_t *field) } static char * -combined_name(cbl_label_t *label) +combined_name(const cbl_label_t *label) { // This routine returns a pointer to a static, so make sure you use the result // before calling the routine again - char *para_name = nullptr; - char *sect_name = nullptr; + const char *para_name = nullptr; + const char *sect_name = nullptr; const char *program_name = current_function->our_unmangled_name; if( label->type == LblParagraph ) @@ -2264,7 +2583,7 @@ combined_name(cbl_label_t *label) if( label->parent ) { // It's possible for implicit - cbl_label_t *section_label = cbl_label_of(symbol_at(label->parent)); + const cbl_label_t *section_label = cbl_label_of(symbol_at(label->parent)); sect_name = section_label->name; } } @@ -2274,10 +2593,10 @@ combined_name(cbl_label_t *label) } static size_t retval_size = 256; - static char *retval= (char *)xmalloc(retval_size); + static char *retval= static_cast<char *>(xmalloc(retval_size)); char *paragraph = cobol_name_mangler(para_name); - char *section = cobol_name_mangler(sect_name); + char *section = cobol_name_mangler(sect_name); char *mangled_program_name = cobol_name_mangler(program_name); while( retval_size < (paragraph ? strlen(paragraph) : 0 ) @@ -2286,8 +2605,9 @@ combined_name(cbl_label_t *label) + 24 ) { retval_size *= 2; - retval = (char *)xrealloc(retval, retval_size); + retval = static_cast<char *>(xrealloc(retval, retval_size)); } + gcc_assert(retval); *retval = '\0'; char ach[24]; @@ -2305,9 +2625,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); @@ -2332,8 +2654,9 @@ assembler_label(const char *label) { length = strlen(label) + strlen(local_text) + 1; free(build); - build = (char *)xmalloc(length); + build = static_cast<char *>(xmalloc(length)); } + gcc_assert(build); strcpy(build, label); strcat(build, local_text); @@ -2347,41 +2670,31 @@ section_label(struct cbl_proc_t *procedure) // With nested programs, you can have multiple program/section pairs with the // the same names; we use a deconflictor to avoid collisions - gg_set_current_line_number(CURRENT_LINE_NUMBER); - size_t deconflictor = symbol_label_id(procedure->label); cbl_label_t *label = procedure->label; // The _initialize_program section isn't relevant. - static size_t psz_length = 256; - static char *psz = (char *)xmalloc(psz_length); - sprintf(psz, - "# SECTION %s in %s (%ld)", - label->name, - current_function->our_unmangled_name, - deconflictor); + char *psz = xasprintf("%s SECTION %s in %s (" HOST_SIZE_T_PRINT_DEC ")", + ASM_COMMENT_START, + label->name, + current_function->our_unmangled_name, + (fmt_size_t)deconflictor); gg_insert_into_assembler(psz); + free(psz); // The label has to start with an underscore. I tried a period, but those // don't seem to show up in GDB's internal symbol tables. - char *combined = combined_name(procedure->label); - if( psz_length < strlen(combined) + 36 + 1 ) - { - free(psz); - psz_length = strlen(combined) + 36 + 1; - psz = (char *)xmalloc(psz_length); - } - sprintf(psz, - "_sect.%s", - combined_name(procedure->label)); + char *psz2 = xasprintf( "_sect.%s", + combined_name(procedure->label)); SHOW_PARSE { SHOW_PARSE_HEADER - SHOW_PARSE_TEXT(psz); + SHOW_PARSE_TEXT(psz2); SHOW_PARSE_END } - assembler_label(psz); - gg_assign(var_decl_nop, build_int_cst_type(INT, 108)); + assembler_label(psz2); + free(psz2); + insert_nop(108); } static void @@ -2396,8 +2709,6 @@ paragraph_label(struct cbl_proc_t *procedure) // are not referenced by the program. We provide a deconflictor to // separate such labels. - gg_set_current_line_number(CURRENT_LINE_NUMBER); - cbl_label_t *paragraph = procedure->label; cbl_label_t *section = nullptr; @@ -2409,41 +2720,54 @@ paragraph_label(struct cbl_proc_t *procedure) char *para_name = paragraph->name; char *section_name = section ? section->name : nullptr; - static size_t psz_length = 256; - static char *psz = (char *)xmalloc(psz_length); + size_t deconflictor = symbol_label_id(procedure->label); + + char *psz1 = + xasprintf( + "%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: "" , + (fmt_size_t)deconflictor ); - static size_t deconflictor = symbol_label_id(procedure->label); + // (0) is wrong, so back up one - sprintf(psz, - "# PARAGRAPH %s of %s in %s (%ld)", - para_name, - section_name, - current_function->our_unmangled_name, - deconflictor); - gg_insert_into_assembler(psz); + gg_insert_into_assembler(psz1); SHOW_PARSE { SHOW_PARSE_HEADER - SHOW_PARSE_TEXT(psz); + SHOW_PARSE_TEXT(psz1); SHOW_PARSE_END } + free(psz1); // The label has to start with an underscore. I tried a period, but those // don't seem to show up in GDB's internal symbol tables. - char *combined = combined_name(procedure->label); - if( psz_length < strlen(combined) + 36 + 1 ) - { - free(psz); - psz_length = strlen(combined) + 36 + 1; - psz = (char *)xmalloc(psz_length); - } - - sprintf(psz, - "_para.%s", - combined_name(procedure->label)); - assembler_label(psz); - gg_assign(var_decl_nop, build_int_cst_type(INT, 109)); + char *psz2 = xasprintf( "_para.%s", + combined_name(procedure->label)); + assembler_label(psz2); + free(psz2); + + // We are inserting a NOP after having created a label for the procedure. + // This means that when using GDC_COBOL to step into a procedure, the + // execution will stop there and show "123 para-name." at the stopped point. + // + // Note that because there is no user-specified executable code at that point + // the user can't set a working breakpoint with "break 123". But because + // GDB will pick up the psz2 text and set a breakpoint there (which is the + // location of the NOP) "break para-name" will actually stop and show line + // 123. + // + // This really only makes sense when you look at the assembly language. Keep + // in mind as you read it that issuing a "break 123" causes GDB to set a + // breakpoint at the first executable machine language code following the + // first ".loc 123" directive. + // + // Yes, trying to understand this causes headaches for many people who read + // this. Take an aspirin. + insert_nop(109); } static void @@ -2487,6 +2811,7 @@ pseudo_return_pop(cbl_proc_t *procedure) NULL_TREE); } + token_location_override(current_location_minus_one()); IF( var_decl_exit_address, eq_op, procedure->exit.addr ) { TRACE1 @@ -2496,11 +2821,13 @@ pseudo_return_pop(cbl_proc_t *procedure) // The top of the stack is us! // Pick up the return address from the pseudo_return stack: + token_location_override(current_location_minus_one()); gg_assign(current_function->void_star_temp, gg_call_expr( VOID_P, "__gg__pseudo_return_pop", NULL_TREE)); // And do the return: + token_location_override(current_location_minus_one()); gg_goto(current_function->void_star_temp); } ELSE @@ -2534,13 +2861,15 @@ leave_procedure(struct cbl_proc_t *procedure, bool /*section*/) // procedure->bottom.label); // Procedure can be null, for example at the beginning of a // new program, or after somebody else has cleared it out. + gg_append_statement(procedure->exit.label); - char ach[256]; - sprintf(ach, - "_procret.%ld:", - symbol_label_id(procedure->label)); - gg_insert_into_assembler(ach); + char *psz; + psz = xasprintf("_procret." HOST_SIZE_T_PRINT_DEC ":", + (fmt_size_t)symbol_label_id(procedure->label)); + token_location_override(current_location_minus_one()); + gg_insert_into_assembler(psz); + free(psz); pseudo_return_pop(procedure); gg_append_statement(procedure->bottom.label); } @@ -2649,10 +2978,11 @@ find_procedure(cbl_label_t *label) if( !retval ) { static int counter=1; - char ach[2*sizeof(cbl_name_t)]; // This is a new section or paragraph; we need to create its values: - retval = (struct cbl_proc_t *)xmalloc(sizeof(struct cbl_proc_t)); + retval = static_cast<struct cbl_proc_t *> + (xmalloc(sizeof(struct cbl_proc_t))); + gcc_assert(retval); retval->label = label; gg_create_goto_pair(&retval->top.go_to, @@ -2680,8 +3010,9 @@ find_procedure(cbl_label_t *label) // If this procedure is a paragraph, and it becomes the target of // an ALTER statement, alter_location will be used to make that change - sprintf(ach, "_%s_alter_loc_%d", label->name, counter); - retval->alter_location = gg_define_void_star(ach, vs_static); + char *psz = xasprintf("_%s_alter_loc_%d", label->name, counter); + retval->alter_location = gg_define_void_star(psz, vs_static); + free(psz); DECL_INITIAL(retval->alter_location) = null_pointer_node; counter +=1 ; @@ -2707,6 +3038,8 @@ parser_enter_section(cbl_label_t *label) { SHOW_PARSE_HEADER SHOW_PARSE_LABEL(" ", label) + SHOW_PARSE_INDENT + linemap_dump_location( line_table, current_token_location(), stderr ); SHOW_PARSE_END } @@ -2714,8 +3047,7 @@ parser_enter_section(cbl_label_t *label) // This NOP is needed to give GDB a line number for the entry point of // paragraphs - gg_set_current_line_number(CURRENT_LINE_NUMBER); - gg_assign(var_decl_nop, build_int_cst_type(INT, 101)); + insert_nop(101); struct cbl_proc_t *procedure = find_procedure(label); gg_append_statement(procedure->top.label); @@ -2742,6 +3074,8 @@ parser_enter_paragraph(cbl_label_t *label) { SHOW_PARSE_HEADER SHOW_PARSE_LABEL(" ", label) + SHOW_PARSE_INDENT + linemap_dump_location( line_table, current_token_location(), stderr ); SHOW_PARSE_END } @@ -2883,10 +3217,10 @@ parser_goto( cbl_refer_t value_ref, size_t narg, cbl_label_t * const labels[] ) // We need to create a static array of pointers to locations: static int comp_gotos = 1; - char ach[32]; - sprintf(ach, "_comp_goto_%d", comp_gotos++); + char *psz = xasprintf("_comp_goto_%d", comp_gotos++); tree array_of_pointers_type = build_array_type_nelts(VOID_P, narg); - tree array_of_pointers = gg_define_variable(array_of_pointers_type, ach, vs_static); + tree array_of_pointers = gg_define_variable(array_of_pointers_type, psz, vs_static); + free(psz); // We have the array. Now we need to build the constructor for it tree constr = make_node(CONSTRUCTOR); @@ -2912,7 +3246,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: @@ -2957,16 +3291,20 @@ parser_goto( cbl_refer_t value_ref, size_t narg, cbl_label_t * const labels[] ) void parser_perform(cbl_label_t *label, bool suppress_nexting) { - label->used = yylineno; Analyze(); SHOW_PARSE { SHOW_PARSE_HEADER SHOW_PARSE_LABEL(" ", label) char ach[32]; - sprintf(ach, " label is at %p", (void*)label); + sprintf(ach, " label is at %p", static_cast<void*>(label)); SHOW_PARSE_TEXT(ach) - sprintf(ach, " label->proc is %p", (void*)label->structs.proc); + if( label ) + { + sprintf(ach, + " label->proc is %p", + static_cast<void*>(label->structs.proc)); + } SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } @@ -2979,6 +3317,7 @@ parser_perform(cbl_label_t *label, bool suppress_nexting) } CHECK_LABEL(label); + label->used = yylineno; struct cbl_proc_t *procedure = find_procedure(label); @@ -3007,23 +3346,24 @@ parser_perform(cbl_label_t *label, bool suppress_nexting) // pairs were created, the locations of the goto instruction and the label // were not known. - char *para_name = nullptr; - char *sect_name = nullptr; + const char *para_name = nullptr; + const char *sect_name = nullptr; const char *program_name = current_function->our_unmangled_name; size_t deconflictor = symbol_label_id(label); char ach[256]; if( label->type == LblParagraph ) { - cbl_label_t *section_label = cbl_label_of(symbol_at(label->parent)); + const cbl_label_t *sec_label = cbl_label_of(symbol_at(label->parent)); para_name = label->name; - sect_name = section_label->name; + sect_name = sec_label->name; sprintf(ach, - "# 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); } @@ -3031,18 +3371,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 ); } @@ -3075,9 +3416,9 @@ parser_perform_times( cbl_label_t *proc_1, cbl_refer_t count ) SHOW_PARSE_REF(" ", count) SHOW_PARSE_TEXT(" TIMES") char ach[32]; - sprintf(ach, " proc_1 is at %p", (void*)proc_1); + sprintf(ach, " proc_1 is at %p", static_cast<void*>(proc_1)); SHOW_PARSE_TEXT(ach) - sprintf(ach, " proc_1->proc is %p", (void*)proc_1->structs.proc); + sprintf(ach, " proc_1->proc is %p", static_cast<void*>(proc_1->structs.proc)); SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } @@ -3090,8 +3431,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); @@ -3100,7 +3441,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) ) @@ -3112,8 +3453,9 @@ 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); + token_location_override(current_location_minus_one()); gg_insert_into_assembler(ach); } @@ -3128,17 +3470,22 @@ internal_perform_through( cbl_label_t *proc_1, SHOW_PARSE_HEADER SHOW_PARSE_LABEL(" ", proc_1); char ach[32]; - sprintf(ach, " proc_1 is at %p", (void*)proc_1); + sprintf(ach, " proc_1 is at %p", static_cast<void*>(proc_1)); SHOW_PARSE_TEXT(ach) - sprintf(ach, " proc_1->proc is %p", (void*)proc_1->structs.proc); + if( proc_1 ) + { + sprintf(ach, + " proc_1->proc is %p", + static_cast<void*>(proc_1->structs.proc)); + } SHOW_PARSE_TEXT(ach) if( proc_2 ) { SHOW_PARSE_INDENT - SHOW_PARSE_LABEL("", proc_2); - sprintf(ach, " proc_2 is at %p", (void*)proc_2); + SHOW_PARSE_LABEL_OK("", proc_2); + sprintf(ach, " proc_2 is at %p", static_cast<void*>(proc_2)); SHOW_PARSE_TEXT(ach) - sprintf(ach, " proc_2->proc is %p", (void*)proc_2->structs.proc); + sprintf(ach, " proc_2->proc is %p", static_cast<void*>(proc_2->structs.proc)); SHOW_PARSE_TEXT(ach) } SHOW_PARSE_END @@ -3151,14 +3498,12 @@ internal_perform_through( cbl_label_t *proc_1, CHECK_LABEL(proc_1); - if(!proc_2) + if( !proc_2 ) { parser_perform(proc_1, suppress_nexting); return; } - CHECK_LABEL(proc_2); - struct cbl_proc_t *proc1 = find_procedure(proc_1); struct cbl_proc_t *proc2 = find_procedure(proc_2); @@ -3183,15 +3528,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); } @@ -3213,17 +3558,22 @@ internal_perform_through_times( cbl_label_t *proc_1, SHOW_PARSE_HEADER SHOW_PARSE_LABEL(" ", proc_1); char ach[32]; - sprintf(ach, " proc_1 is at %p", (void*)proc_1); + sprintf(ach, " proc_1 is at %p", static_cast<void*>(proc_1)); SHOW_PARSE_TEXT(ach) - sprintf(ach, " proc_1->proc is %p", (void*)proc_1->structs.proc); + if( proc_1 ) + { + sprintf(ach, + " proc_1->proc is %p", + static_cast<void*>(proc_1->structs.proc)); + } SHOW_PARSE_TEXT(ach) if( proc_2 ) { SHOW_PARSE_INDENT - SHOW_PARSE_LABEL("", proc_2); - sprintf(ach, " proc_2 is at %p", (void*)proc_2); + SHOW_PARSE_LABEL_OK("", proc_2); + sprintf(ach, " proc_2 is at %p", static_cast<void*>(proc_2)); SHOW_PARSE_TEXT(ach) - sprintf(ach, " proc_2->proc is %p", (void*)proc_2->structs.proc); + sprintf(ach, " proc_2->proc is %p", static_cast<void*>(proc_2->structs.proc)); SHOW_PARSE_TEXT(ach) } SHOW_PARSE_REF(" ", count); @@ -3240,15 +3590,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 @@ -3257,8 +3607,9 @@ 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); + token_location_override(current_location_minus_one()); gg_insert_into_assembler( ach ); } @@ -3333,17 +3684,16 @@ parser_first_statement( int lineno ) } } -#define linemap_add(...) - void parser_enter_file(const char *filename) { SHOW_PARSE { SHOW_PARSE_HEADER - char ach[32]; - sprintf(ach, " entering level:%d %s", file_level+1, filename); - SHOW_PARSE_TEXT(ach); + char *psz; + psz = xasprintf(" entering level:%d %s", file_level+1, filename); + SHOW_PARSE_TEXT(psz); + free(psz); SHOW_PARSE_END } @@ -3365,9 +3715,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: @@ -3388,8 +3735,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"); @@ -3401,7 +3746,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"); @@ -3432,6 +3776,7 @@ parser_enter_file(const char *filename) SET_VAR_DECL(var_decl_treeplet_4s , SIZE_T_P , "__gg__treeplet_4s" ); SET_VAR_DECL(var_decl_nop , INT , "__gg__nop" ); SET_VAR_DECL(var_decl_main_called , INT , "__gg__main_called" ); + SET_VAR_DECL(var_decl_entry_label , VOID_P , "__gg__entry_label" ); } } @@ -3443,16 +3788,38 @@ parser_leave_file() { SHOW_PARSE_HEADER char ach[256]; - sprintf(ach, "leaving level:%d %s", file_level, current_filename.back().c_str()); + sprintf(ach, + "leaving level:%d %s", + file_level, + current_filename.back().c_str()); SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } - if( file_level > 0) - { - linemap_add(line_table, LC_LEAVE, false, NULL, 0); - } file_level -= 1; current_filename.pop_back(); + + if( file_level == 0 ) + { + // We are leaving the top-level file, which means this compilation is + // done, done, done. + + // There is, however, one thing left to do. If the command line says + // that this module needs a main entry point, then this is where + // we create a main() function. We build it at the end, so that all of + // the .loc directives associated with it appear at the end of the + // source code. We used to create the main() entry point at the beginning, + // but that created confusion for GDB when trying to debug the generated + // executable. + if( main_entry_point ) + { + next_program_is_main = false; + build_main_that_calls_something(main_entry_point); + free(main_entry_point); + main_entry_point = NULL; + } + + gg_leaving_the_source_code_file(); + } } void @@ -3467,15 +3834,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); @@ -3500,27 +3868,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. - - // The text_conversion_override exists both in the library and in the compiler - - __gg__set_internal_codeset(internal_codeset_is_ebcdic()); - gg_call(VOID, - "__gg__set_internal_codeset", - internal_codeset_is_ebcdic() - ? integer_one_node : integer_zero_node, - NULL_TREE); - - __gg__text_conversion_override(td_default_e, cs_default_e); - gg_call(VOID, - "__gg__text_conversion_override", - build_int_cst_type(INT, td_default_e), - build_int_cst_type(INT, cs_default_e), - NULL_TREE); - gg_call(VOID, "__gg__codeset_figurative_constants", NULL_TREE); @@ -3561,19 +3908,22 @@ parser_enter_program( const char *funcname_, // The first thing we have to do is mangle this name. This is safe even // though the end result will be mangled again, because the mangler doesn't // change a mangled name. + char *mangled_name = cobol_name_mangler(funcname_); size_t parent_index = current_program_index(); - char funcname[128]; + char *funcname; if( parent_index ) { // This is a nested function. Tack on the parent_index to the end of it. - sprintf(funcname, "%s.%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); @@ -3587,31 +3937,28 @@ parser_enter_program( const char *funcname_, if( !is_function && !parent_index ) { - // This is a top_level program, and not a function + // This is a top_level program-id, and not a function if( next_program_is_main ) { + // This is the first top-level program-id. next_program_is_main = false; - if(main_entry_point) - { - build_main_that_calls_something(main_entry_point); - free(main_entry_point); - main_entry_point = NULL; - } - else + if( !main_entry_point ) { - build_main_that_calls_something(funcname); + // Because no explicit main_entry_point was specified, this program-id, + // the first in the file, becomes the target of the main() function + // that will be created at parser_leave_file time. + main_entry_point = xstrdup(funcname); + + char *psz = cobol_name_mangler(main_entry_point); + strncpy(ach_cobol_entry_point, psz, sizeof(ach_cobol_entry_point)-1); + free(psz); } } } - // Call this after build_main_that_calls_something, because it manipulates - // the current line number to DEFAULT_LINE_NUMBER. We have to manipulate it - // back afterward. - gg_set_current_line_number(CURRENT_LINE_NUMBER); - if( strcmp(funcname_, "main") == 0 && this_module_has_main ) { - // setting 'retval' to 1 let's the caller know that we are being told + // Setting 'retval' to 1 lets the caller know that we are being told // both to synthesize a main() entry point to duplicate GCC's default // behavior, and to create an explicit entry point named "main". This will // eventually result in a link error (because of the duplicated entry @@ -3639,8 +3986,40 @@ parser_enter_program( const char *funcname_, TRACE1_TEXT("\"") TRACE1_END } + + free(funcname); } +static class label_verify_t { + std::set<size_t> lain, dangling; + static inline size_t index_of( const cbl_label_t *label ) { + return symbol_index(symbol_elem_of(label)); + } +public: + void go_to( const cbl_label_t *label ) { + auto p = lain.find(index_of(label)); + if( p == lain.end() ) { + dangling.insert(index_of(label)); + } + } + void lay( const cbl_label_t *label ) { + auto ok = lain.insert(index_of(label)); + if( ok.second ) { + dangling.erase(index_of(label)); + } + } + bool vet() const { // be always agreeable, for now. + return dangling.empty(); + } + void dump() const { + fprintf(stderr, "%u nonexistent labels called\n", unsigned(dangling.size()) ); + for( auto sym : dangling ) { + const cbl_label_t *label = cbl_label_of(symbol_at(sym)); + fprintf(stderr, "\t %s\n", label->name); + } + } +} label_verify; + void parser_end_program(const char *prog_name ) { @@ -3667,6 +4046,13 @@ parser_end_program(const char *prog_name ) TRACE1_END } + if( ! label_verify.vet() ) + { + label_verify.dump(); + gcc_unreachable(); + } + + if( gg_trans_unit.function_stack.size() ) { // The body has been created by various parser calls. It's time @@ -3734,8 +4120,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, @@ -3773,390 +4159,408 @@ 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", gg_get_address_of(array), - wsclear() ? gg_string_literal(wsclear()) : null_pointer_node, + wsclear() ? build_string_literal(1, (const char *)wsclear()) + : null_pointer_node, NULL_TREE); } -static void -psa_FldLiteralN(struct cbl_field_t *field ) +static +FIXED_WIDE_INT(128) +dirty_to_binary(const char *instring, + uint32_t &capacity, + uint32_t &digits, + int32_t &rdigits, + uint64_t &attr) { - Analyze(); - SHOW_PARSE + digits = 0; + rdigits = 0; + attr = 0; + + FIXED_WIDE_INT(128) value = 0; + + // We need to convert data.initial to an FIXED_WIDE_INT(128) value + const char *p = instring; + int sign = 1; + if( *p == '-' ) { - SHOW_PARSE_HEADER - SHOW_PARSE_FIELD(" ", field) - SHOW_PARSE_END + attr |= signable_e; + sign = -1; + p += 1; + } + else if( *p == '+' ) + { + // We set it signable so that the instruction DISPLAY +1 + // actually outputs "+1" + attr |= signable_e; + p += 1; } - // We are constructing a completely static constant structure, based on the - // text string in .initial -#pragma GCC diagnostic push -#pragma GCC diagnostic ignored "-Wpedantic" - __int128 value = 0; -#pragma GCC diagnostic pop + // We need to be able to handle + // 123 + // 123.456 + // 123E<exp> + // 123.456E<exp> + // where <exp> can be N, +N and -N + // + // Oh, yeah, and we're talking handling up to 32 digits, or more, so using + // library routines is off the table. - do + int rdigit_delta = 0; + int exponent = 0; + const char *exp = strchr(p, 'E'); + if( !exp ) { - // This is a false do{}while, to isolate the variables: - - // We need to convert data.initial to an __int128 value - char *p = const_cast<char *>(field->data.initial); - int sign = 1; - if( *p == '-' ) - { - field->attr |= signable_e; - sign = -1; - p += 1; - } - else if( *p == '+' ) - { - // We set it signable so that the instruction DISPLAY +1 - // actually outputs "+1" - field->attr |= signable_e; - p += 1; - } + exp = strchr(p, 'e'); + } + if(exp) + { + exponent = atoi(exp+1); + } - // We need to be able to handle - // 123 - // 123.456 - // 123E<exp> - // 123.456E<exp> - // where <exp> can be N, +N and -N - // - // Oh, yeah, and we're talking handling up to 32 digits, or more, so using - // library routines is off the table. + // We can now calculate the value, and the number of digits and rdigits. - int digits = 0; - int rdigits = 0; - int rdigit_delta = 0; - int exponent = 0; + // We count up leading zeroes as part of the attr->digits calculation. + // It turns out that certain comparisons need to know the number of digits, + // because "IF "2" EQUAL 002" is false, while "IF "2" EQUAL 2" is true. So, + // we need to count up leading zeroes. - char *exp = strchr(p, 'E'); - if( !exp ) + for(;;) + { + char ch = *p++; + if( ch == symbol_decimal_point() ) { - exp = strchr(p, 'e'); + rdigit_delta = 1; + continue; } - if(exp) + if( ch < '0' || ch > '9' ) { - exponent = atoi(exp+1); + break; } + digits += 1; + rdigits += rdigit_delta; + value *= 10; + value += ch - '0'; + } - // We can now calculate the value, and the number of digits and rdigits. - - // We count up leading zeroes as part of the attr->digits calculation. - // It turns out that certain comparisons need to know the number of digits, - // because "IF "2" EQUAL 002" is false, while "IF "2" EQUAL 2" is true. So, - // we need to count up leading zeroes. - - for(;;) + if( exponent < 0 ) + { + rdigits += -exponent; + } + else + { + while(exponent--) { - char ch = *p++; - if( ch == symbol_decimal_point() ) - { - rdigit_delta = 1; - continue; - } - if( ch < '0' || ch > '9' ) + if(rdigits) { - break; + rdigits -= 1; } - digits += 1; - rdigits += rdigit_delta; - value *= 10; - value += ch - '0'; - } - - if( exponent < 0 ) - { - rdigits += -exponent; - } - else - { - while(exponent--) + else { - if(rdigits) - { - rdigits -= 1; - } - else - { - digits += 1; - value *= 10; - } + digits += 1; + value *= 10; } } + } - if(digits < rdigits) - { - digits = rdigits; - } - field->data.digits = digits; - field->data.rdigits = rdigits; + if( (int32_t)digits < rdigits ) + { + digits = rdigits; + } - // We now need to calculate the capacity. + // We now need to calculate the capacity. - unsigned char *pvalue = (unsigned char *)&value; - int capacity; - if( *(uint64_t*)(pvalue + 8) ) - { - // Bytes 15 through 8 are non-zero - capacity = 16; - } - else if( *(uint32_t*)(pvalue + 4) ) - { - // Bytes 7 through 4 are non-zero - capacity = 8; - } - else if( *(uint16_t*)(pvalue + 2) ) - { - // Bytes 3 and 2 - capacity = 4; - } - else if( pvalue[1] ) - { - // Byte 1 is non-zero - capacity = 2; - } - else - { - // The value is zero through 0xFF - capacity = 1; - } + unsigned int min_prec = wi::min_precision(value, UNSIGNED); + if( min_prec > 64 ) + { + // Bytes 15 through 8 are non-zero + capacity = 16; + } + else if( min_prec > 32 ) + { + // Bytes 7 through 4 are non-zero + capacity = 8; + } + else if( min_prec > 16 ) + { + // Bytes 3 and 2 + capacity = 4; + } + else if( min_prec > 8 ) + { + // Byte 1 is non-zero + capacity = 2; + } + else + { + // The value is zero through 0xFF + capacity = 1; + } - value *= sign; + value *= sign; - // One last adjustment. The number is signable, so the binary value - // is going to be treated as twos complement. That means that the highest - // bit has to be 1 for negative signable numbers, and 0 for positive. If - // necessary, adjust capacity up by one byte so that the variable fits: + // One last adjustment. The number is signable, so the binary value + // is going to be treated as twos complement. That means that the highest + // bit has to be 1 for negative signable numbers, and 0 for positive. If + // necessary, adjust capacity up by one byte so that the variable fits: - if( capacity < 16 && (field->attr & signable_e) ) + if( capacity < 16 && (attr & signable_e) ) + { + FIXED_WIDE_INT(128) mask + = wi::set_bit_in_zero<FIXED_WIDE_INT(128)>(capacity * 8 - 1); + if( wi::neg_p (value) && (value & mask) == 0 ) { - if( value < 0 && (((pvalue[capacity-1] & 0x80) == 0 ))) - { - capacity *= 2; - } - else if( value >= 0 && (((pvalue[capacity-1] & 0x80) == 0x80 ))) - { - capacity *= 2; - } + capacity *= 2; } - field->data.capacity = capacity; - - }while(0); - - char base_name[257]; - char id_string[32] = ""; - - static size_t our_index = 0; - - sprintf(id_string, ".%ld", ++our_index); - strcpy(base_name, field->name); - strcat(base_name, id_string); - - tree var_type; - - if( field->data.capacity == 16 ) - { - /* GCC-13 has no provision for an int128 constructor. So, we use a - union for our necessary __int128. - - typedef union cblc_int128_t - { - unsigned char array16[16]; - __uint128 uval128; - __int128 sval128; - } cblc_int128_t; - - We build a constructor for the array16[], and then we use that - constructor in the constructor for the union. - */ - - // Build the constructor for array16 - tree array16_type = build_array_type_nelts(UCHAR, 16); - tree array_16_constructor = make_node(CONSTRUCTOR); - TREE_TYPE(array_16_constructor) = array16_type; - TREE_STATIC(array_16_constructor) = 1; - TREE_CONSTANT(array_16_constructor) = 1; - - for(int i=0; i<16; i++) + else if( !wi::neg_p (value) && (value & mask) != 0 ) { - CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(array_16_constructor), - build_int_cst_type(INT, i), - build_int_cst_type(UCHAR, - ((unsigned char *)&value)[i])); + capacity *= 2; } - - // The array16 constructor is ready to be used - - // So, we need a constructor for the union: - // Now we create the union: - var_type = cblc_int128_type_node; - - tree union_constructor = make_node(CONSTRUCTOR); - TREE_TYPE(union_constructor) = var_type; - TREE_STATIC(union_constructor) = 1; - TREE_CONSTANT(union_constructor) = 1; - - // point next_field to the first field of the union, and - // set the value to be the table constructor - tree next_field = TYPE_FIELDS(var_type); - CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(union_constructor), - next_field, - array_16_constructor ); - - tree new_var_decl = gg_define_variable( var_type, - base_name, - vs_static); - DECL_INITIAL(new_var_decl) = union_constructor; - - field->data_decl_node = member(new_var_decl, "sval128"); - TREE_READONLY(field->data_decl_node) = 1; - TREE_CONSTANT(field->data_decl_node) = 1; - - // Convert the compile-time data.value to a run-time variable decl node: - sprintf(id_string, ".%ld", ++our_index); - strcpy(base_name, field->name); - strcat(base_name, id_string); - field->literal_decl_node = gg_define_variable(DOUBLE, id_string, vs_static); - TREE_READONLY(field->literal_decl_node) = 1; - TREE_CONSTANT(field->literal_decl_node) = 1; - char ach[128]; - strfromf128(ach, sizeof(ach), "%.36E", field->data.value_of()); - REAL_VALUE_TYPE real; - real_from_string(&real, ach); - tree initer = build_real (DOUBLE, real); - DECL_INITIAL(field->literal_decl_node) = initer; - - } - else - { - // The value is 1, 2, 4, or 8 bytes, so an ordinary constructor can be used. - var_type = tree_type_from_size( field->data.capacity, - field->attr & signable_e); - tree new_var_decl = gg_define_variable( var_type, - base_name, - vs_static); - DECL_INITIAL(new_var_decl) = build_int_cst_type(var_type, value); - field->data_decl_node = new_var_decl; } + + return value; } static void -psa_FldBlob(struct cbl_field_t *var ) +psa_FldLiteralN(struct cbl_field_t *field ) { Analyze(); SHOW_PARSE { SHOW_PARSE_HEADER - SHOW_PARSE_FIELD(" ", var) + SHOW_PARSE_FIELD(" ", field) SHOW_PARSE_END } + // We are constructing a completely static constant structure, based on the + // text string in .initial - // We are constructing a completely static constant structure. We know the - // capacity. We'll create it from the data.initial. The var_decl_node will - // be a pointer to the data + CHECK_FIELD(field); + + uint32_t capacity; + uint32_t digits; + int32_t rdigits; + uint64_t attr; + FIXED_WIDE_INT(128) value = dirty_to_binary(field->data.original(), + capacity, + digits, + rdigits, + attr); + // This is a rare occurrence of a parser_xxx call changing the entry + // in the symbol table. + field->data.capacity = capacity; + field->data.digits = digits; + field->data.rdigits = rdigits; + field->attr |= attr; char base_name[257]; char id_string[32] = ""; static size_t our_index = 0; - sprintf(id_string, ".%ld", ++our_index); - strcpy(base_name, var->name); + sprintf(id_string, "." HOST_SIZE_T_PRINT_DEC, (fmt_size_t)++our_index); + strcpy(base_name, field->name); strcat(base_name, id_string); - // Build the constructor for the array of bytes - - tree array_type = build_array_type_nelts(UCHAR, var->data.capacity); - tree array_constructor = make_node(CONSTRUCTOR); - TREE_TYPE(array_constructor) = array_type; - TREE_STATIC(array_constructor) = 1; - TREE_CONSTANT(array_constructor) = 1; - - for(size_t i=0; i<var->data.capacity; i++) - { - CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(array_constructor), - build_int_cst_type(INT, i), - build_int_cst_type(UCHAR, var->data.initial[i])); - } + tree var_type; - // The array constructor is ready to be used - tree var_decl_node = gg_define_variable( array_type, + // The value is 1, 2, 4, 8 or 16 bytes, so an ordinary constructor can be + // used. + var_type = tree_type_from_size( field->data.capacity, + field->attr & signable_e); + tree new_var_decl = gg_define_variable( var_type, base_name, vs_static); - DECL_INITIAL(var_decl_node) = array_constructor; - var->var_decl_node = gg_get_address_of(var_decl_node); + 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) ) } void -parser_accept( struct cbl_refer_t refer, - enum special_name_t special_e ) +parser_accept(const struct cbl_refer_t &tgt, + special_name_t special_e, + cbl_label_t *error, + cbl_label_t *not_error ) { - Analyze(); SHOW_PARSE { SHOW_PARSE_HEADER - SHOW_PARSE_REF(" ", refer); + if( error ) + { + SHOW_PARSE_LABEL(" error ", error) + } + if( not_error ) + { + SHOW_PARSE_LABEL(" not_error ", not_error) + } SHOW_PARSE_END } - TRACE1 - { - TRACE1_HEADER - TRACE1_END - } - - /* - enum special_name_t - { - SYSIN_e, - SYSIPT_e, - SYSOUT_e, - SYSLIST_e, - SYSLST_e, - SYSPUNCH_e, - SYSPCH_e, - CONSOLE_e, - C01_e, C02_e, C03_e, C04_e, C05_e, C06_e, - C07_e, C08_e, C09_e, C10_e, C11_e, C12_e, - CSP_e, - S01_e, S02_e, S03_e, S04_e, S05_e, - AFP_5A_e, - }; - */ // The ISO spec describes the valid special names for ACCEPT as implementation // dependent. We are following IBM's lead. tree environment = build_int_cst_type(INT, special_e); - switch( special_e ) + const char *function_to_call = NULL; + + switch(special_e) { + case STDIN_e: case CONSOLE_e: case SYSIPT_e: case SYSIN_e: - break; - default: - dbgmsg("%s(): We don't know what to do with special_name_t %d,", __func__, special_e); - dbgmsg("%s(): so we are ignoring it.", __func__); - yywarn("unrecognized SPECIAL NAME ignored"); + // This is ordinary input from from the stdin: + gg_call(VOID, + "__gg__accept", + environment, + gg_get_address_of(tgt.field->var_decl_node), + refer_offset(tgt), + refer_size_dest(tgt), + NULL_TREE); return; break; - } - gg_call(VOID, - "__gg__accept", - environment, - gg_get_address_of(refer.field->var_decl_node), - refer_offset_dest(refer), - refer_size_dest(refer), - NULL_TREE); + case C01_e: + case C02_e: + case C03_e: + case C04_e: + case C05_e: + case C06_e: + case C07_e: + case C08_e: + case C09_e: + case C10_e: + case C11_e: + case C12_e: + case CSP_e: + case S01_e: + case S02_e: + case S03_e: + case S04_e: + case S05_e: + case AFP_5A_e: + case STDOUT_e: + case SYSOUT_e: + case SYSLIST_e: + case SYSLST_e: + case STDERR_e: + case SYSPUNCH_e: + case SYSPCH_e: + case SYSERR_e: + cbl_internal_error("Not valid for ACCEPT statement."); + break; + + case ARG_NUM_e: + // This ACCEPT statement wants the number of argv values: + gg_call(VOID, + "__gg__get_argc", + gg_get_address_of(tgt.field->var_decl_node), + refer_offset(tgt), + refer_size_source(tgt), + NULL_TREE); + return; + break; + + case ENV_NAME_e: + // This fetches the environment name set by DISPLAY... UPON ENV_NAME_e + gg_call(VOID, + "__gg__get_env_name", + gg_get_address_of(tgt.field->var_decl_node), + refer_offset(tgt), + refer_size_source(tgt), + NULL_TREE); + return; + break; + + case ENV_VALUE_e: + // This fetches the environment value associated with the previously + // esablished name + function_to_call = "__gg__get_env_value"; + break; + + case ARG_VALUE_e: + // We are fetching the variable whose index was established by a prior + // DISPLAY UPON ARGUMENT-NUMBER. After the fetch, the value will be + // incremented by one. + function_to_call = "__gg__accept_arg_value"; + break; + } + if( function_to_call ) + { + tree erf = gg_define_int(); + gg_assign(erf, + gg_call_expr( INT, + function_to_call, + gg_get_address_of(tgt.field->var_decl_node), + refer_offset(tgt), + refer_size_dest(tgt), + NULL_TREE)); + if( error ) + { + // There is an ON EXCEPTION phrase: + IF( erf, ne_op, integer_zero_node ) + { + SHOW_PARSE + { + SHOW_PARSE_INDENT + SHOW_PARSE_TEXT("Laying down GOTO error->INTO for_argv") + SHOW_PARSE_LABEL_OK(" ", error) + } + gg_append_statement( error->structs.arith_error->into.go_to ); + } + ELSE + { + } + ENDIF + } + if( not_error ) + { + // There is an NOT ON EXCEPTION phrase: + IF( erf, eq_op, integer_zero_node ) + { + SHOW_PARSE + { + SHOW_PARSE_INDENT + SHOW_PARSE_TEXT("Laying down GOTO not_error->INTO for_argv") + SHOW_PARSE_LABEL_OK(" ", not_error) + } + gg_append_statement( not_error->structs.arith_error->into.go_to ); + } + ELSE + { + } + ENDIF + } + if( error ) + { + SHOW_PARSE + { + SHOW_PARSE_INDENT + SHOW_PARSE_TEXT("Laying down LABEL error->bottom") + SHOW_PARSE_LABEL_OK(" ", error) + } + gg_append_statement( error->structs.arith_error->bottom.label ); + } + if( not_error ) + { + SHOW_PARSE + { + SHOW_PARSE_INDENT + SHOW_PARSE_TEXT("Laying down LABEL not_error->bottom") + SHOW_PARSE_LABEL_OK(" ", not_error) + SHOW_PARSE_END + } + gg_append_statement( not_error->structs.arith_error->bottom.label ); + } + } } // TODO: update documentation. @@ -4168,7 +4572,6 @@ parser_accept_exception( cbl_label_t *accept_label ) // We are entering either SIZE ERROR or NOT SIZE ERROR code RETURN_IF_PARSE_ONLY; - set_up_on_exception_label(accept_label); SHOW_PARSE { @@ -4181,6 +4584,9 @@ parser_accept_exception( cbl_label_t *accept_label ) SHOW_PARSE_END } + CHECK_LABEL(accept_label); + set_up_on_exception_label(accept_label); + // Jump over the [NOT] ON EXCEPTION code that is about to be laid down gg_append_statement( accept_label->structs.arith_error->over.go_to ); // Create the label that allows the following code to be executed at @@ -4207,6 +4613,8 @@ parser_accept_exception_end( cbl_label_t *accept_label ) SHOW_PARSE_END } + CHECK_LABEL(accept_label); + // Jump to the end of the arithmetic code: gg_append_statement( accept_label->structs.arith_error->bottom.go_to ); // Lay down the label that allows the ERROR/NOT ERROR instructions @@ -4216,8 +4624,8 @@ parser_accept_exception_end( cbl_label_t *accept_label ) } void -parser_accept_command_line( cbl_refer_t tgt, - cbl_refer_t source, +parser_accept_command_line( const cbl_refer_t &tgt, + const cbl_refer_t &source, cbl_label_t *error, cbl_label_t *not_error ) { @@ -4245,7 +4653,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 ) @@ -4257,7 +4665,7 @@ parser_accept_command_line( cbl_refer_t tgt, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("Laying down GOTO error->INTO for_command_line") - SHOW_PARSE_LABEL(" ", error) + SHOW_PARSE_LABEL_OK(" ", error) } gg_append_statement( error->structs.arith_error->into.go_to ); } @@ -4275,7 +4683,7 @@ parser_accept_command_line( cbl_refer_t tgt, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("Laying down GOTO not_error->INTO for command_line") - SHOW_PARSE_LABEL(" ", not_error) + SHOW_PARSE_LABEL_OK(" ", not_error) } gg_append_statement( not_error->structs.arith_error->into.go_to ); } @@ -4292,10 +4700,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 ) @@ -4307,7 +4715,7 @@ parser_accept_command_line( cbl_refer_t tgt, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("Laying down GOTO error->INTO for_argv") - SHOW_PARSE_LABEL(" ", error) + SHOW_PARSE_LABEL_OK(" ", error) } gg_append_statement( error->structs.arith_error->into.go_to ); } @@ -4325,7 +4733,7 @@ parser_accept_command_line( cbl_refer_t tgt, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("Laying down GOTO not_error->INTO for_argv") - SHOW_PARSE_LABEL(" ", not_error) + SHOW_PARSE_LABEL_OK(" ", not_error) } gg_append_statement( not_error->structs.arith_error->into.go_to ); } @@ -4341,7 +4749,7 @@ parser_accept_command_line( cbl_refer_t tgt, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("Laying down LABEL error->bottom") - SHOW_PARSE_LABEL(" ", error) + SHOW_PARSE_LABEL_OK(" ", error) } gg_append_statement( error->structs.arith_error->bottom.label ); } @@ -4351,7 +4759,7 @@ parser_accept_command_line( cbl_refer_t tgt, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("Laying down LABEL not_error->bottom") - SHOW_PARSE_LABEL(" ", not_error) + SHOW_PARSE_LABEL_OK(" ", not_error) SHOW_PARSE_END } gg_append_statement( not_error->structs.arith_error->bottom.label ); @@ -4359,7 +4767,7 @@ parser_accept_command_line( cbl_refer_t tgt, } void -parser_accept_command_line_count( cbl_refer_t tgt ) +parser_accept_command_line_count( const cbl_refer_t &tgt ) { Analyze(); SHOW_PARSE @@ -4375,16 +4783,16 @@ 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); } void -parser_accept_envar(struct cbl_refer_t tgt, - struct cbl_refer_t envar, - cbl_label_t *error, - cbl_label_t *not_error ) +parser_accept_envar(const struct cbl_refer_t &tgt, + const struct cbl_refer_t &envar, + cbl_label_t *error, + cbl_label_t *not_error ) { Analyze(); @@ -4413,10 +4821,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 ) @@ -4449,7 +4857,7 @@ parser_accept_envar(struct cbl_refer_t tgt, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("Laying down LABEL error->bottom") - SHOW_PARSE_LABEL(" ", error) + SHOW_PARSE_LABEL_OK(" ", error) } gg_append_statement( error->structs.arith_error->bottom.label ); } @@ -4459,7 +4867,7 @@ parser_accept_envar(struct cbl_refer_t tgt, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("Laying down LABEL not_error->bottom") - SHOW_PARSE_LABEL(" ", not_error) + SHOW_PARSE_LABEL_OK(" ", not_error) SHOW_PARSE_END } gg_append_statement( not_error->structs.arith_error->bottom.label ); @@ -4467,7 +4875,8 @@ parser_accept_envar(struct cbl_refer_t tgt, } void -parser_set_envar( struct cbl_refer_t name, struct cbl_refer_t value ) +parser_set_envar( const struct cbl_refer_t &name, + const struct cbl_refer_t &value ) { Analyze(); SHOW_PARSE @@ -4485,10 +4894,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); } @@ -4508,8 +4917,8 @@ parser_accept_date_yymmdd( struct cbl_field_t *target ) tree pointer = gg_define_char_star(); gg_assign(pointer, gg_call_expr(CHAR_P, "__gg__get_date_yymmdd", + gg_get_address_of(target->var_decl_node), NULL_TREE)); - gg_default_qualification(target); move_tree_to_field( target, pointer); @@ -4538,8 +4947,8 @@ parser_accept_date_yyyymmdd( struct cbl_field_t *target ) tree pointer = gg_define_char_star(); gg_assign(pointer, gg_call_expr(CHAR_P, "__gg__get_date_yyyymmdd", + gg_get_address_of(target->var_decl_node), NULL_TREE)); - gg_default_qualification(target); move_tree_to_field( target, pointer); @@ -4568,8 +4977,8 @@ parser_accept_date_yyddd( struct cbl_field_t *target ) tree pointer = gg_define_char_star(); gg_assign(pointer, gg_call_expr(CHAR_P, "__gg__get_date_yyddd", + gg_get_address_of(target->var_decl_node), NULL_TREE)); - gg_default_qualification(target); move_tree_to_field( target, pointer); @@ -4598,8 +5007,8 @@ parser_accept_date_yyyyddd( struct cbl_field_t *target ) tree pointer = gg_define_char_star(); gg_assign(pointer, gg_call_expr(CHAR_P, "__gg__get_yyyyddd", + gg_get_address_of(target->var_decl_node), NULL_TREE)); - gg_default_qualification(target); move_tree_to_field( target, pointer); @@ -4628,8 +5037,8 @@ parser_accept_date_dow( struct cbl_field_t *target ) tree pointer = gg_define_char_star(); gg_assign(pointer, gg_call_expr(CHAR_P, "__gg__get_date_dow", + gg_get_address_of(target->var_decl_node), NULL_TREE)); - gg_default_qualification(target); move_tree_to_field( target, pointer); @@ -4658,8 +5067,8 @@ parser_accept_date_hhmmssff( struct cbl_field_t *target ) tree pointer = gg_define_char_star(); gg_assign(pointer, gg_call_expr(CHAR_P, "__gg__get_date_hhmmssff", + gg_get_address_of(target->var_decl_node), NULL_TREE)); - gg_default_qualification(target); move_tree_to_field( target, pointer); @@ -4682,43 +5091,62 @@ parser_accept_date_hhmmssff( struct cbl_field_t *target ) * * The parameter is always a reference to an element in the symbol table. */ + void -parser_alphabet( cbl_alphabet_t& alphabet ) +parser_alphabet( const cbl_alphabet_t& alphabet ) { Analyze(); SHOW_PARSE { SHOW_PARSE_HEADER - fprintf(stderr, "%s\n", alphabet.name); + char *psz = xasprintf(" %s ", alphabet.name); + SHOW_PARSE_TEXT(psz); + free(psz); switch(alphabet.encoding) { + case iconv_CP1252_e: + psz = xasprintf("CP1252"); + break; case ASCII_e: - fprintf(stderr, "ASCII\n"); + psz = xasprintf("ASCII"); break; case iso646_e: - fprintf(stderr, "ISO646\n"); + psz = xasprintf("ISO646"); break; case EBCDIC_e: - fprintf(stderr, "EBCDIC\n"); + psz = xasprintf("EBCDIC"); + break; + case UTF8_e: + psz = xasprintf("UTF8"); break; case custom_encoding_e: - fprintf(stderr, "%s\n", alphabet.name); + psz = xasprintf("%s", alphabet.name); break; + default: + { const char * p = __gg__encoding_iconv_name( alphabet.encoding ); + psz = xasprintf("%s", p? p : "[unknown]"); + } } + SHOW_PARSE_TEXT(" "); + SHOW_PARSE_TEXT(psz); + free(psz); SHOW_PARSE_END } - size_t alphabet_index = symbol_index(symbol_elem_of(&alphabet)); - switch(alphabet.encoding) { + case iconv_CP1252_e: case ASCII_e: case iso646_e: case EBCDIC_e: + case UTF8_e: break; case custom_encoding_e: { +#pragma message "Verify program-id is disambiguated" + size_t alphabet_index = symbol_unique_index(symbol_elem_of(&alphabet)); + unsigned char ach[256]; tree table_type = build_array_type_nelts(UCHAR, 256); @@ -4726,27 +5154,35 @@ parser_alphabet( cbl_alphabet_t& alphabet ) for( int i=0; i<256; i++ ) { // character i has the ordinal alphabet[i] - unsigned char ch = ascii_to_internal(i); + unsigned char ch = i; - ach[ch] = (alphabet.alphabet[i]); + ach[ch] = (alphabet.collation_sequence[i]); gg_assign( gg_array_value(table256, ch), - build_int_cst_type(UCHAR, (alphabet.alphabet[i])) ); + build_int_cst_type(UCHAR, (alphabet.collation_sequence[i])) ); } + + unsigned int low_char = alphabet.low_char; + unsigned int high_char = alphabet.high_char; __gg__alphabet_create(alphabet.encoding, alphabet_index, ach, - alphabet.low_index, - alphabet.high_index); + low_char, + high_char); gg_call(VOID, "__gg__alphabet_create", build_int_cst_type(INT, alphabet.encoding), build_int_cst_type(SIZE_T, alphabet_index), gg_get_address_of(table256), - build_int_cst_type(INT, alphabet.low_index), - build_int_cst_type(INT, alphabet.high_index), + build_int_cst_type(INT, low_char), + build_int_cst_type(INT, high_char), NULL_TREE ); break; } + default: + fprintf(stderr, "%s: Program ID %s:\n", + cobol_filename(), + cbl_label_of(symbol_at(current_program_index()))->name); + gcc_unreachable(); } } @@ -4757,21 +5193,34 @@ parser_alphabet_use( cbl_alphabet_t& alphabet ) SHOW_PARSE { SHOW_PARSE_HEADER + char *psz = xasprintf(" %s ", alphabet.name); + SHOW_PARSE_TEXT(psz); + free(psz); switch(alphabet.encoding) { + case iconv_CP1252_e: + psz = xasprintf("CP1252"); + break; case ASCII_e: - fprintf(stderr, "ASCII\n"); + psz = xasprintf("ASCII"); break; case iso646_e: - fprintf(stderr, "ISO646\n"); + psz = xasprintf("ISO646"); break; case EBCDIC_e: - fprintf(stderr, "EBCDIC\n"); + psz = xasprintf("EBCDIC"); + break; + case UTF8_e: + psz = xasprintf("UTF8"); break; case custom_encoding_e: - fprintf(stderr, "%s\n", alphabet.name); + psz = xasprintf("%s", alphabet.name); break; + default: + gcc_unreachable(); } + SHOW_PARSE_TEXT(psz); + free(psz); SHOW_PARSE_END } @@ -4779,13 +5228,19 @@ parser_alphabet_use( cbl_alphabet_t& alphabet ) switch(alphabet.encoding) { + default: + gcc_unreachable(); + case iconv_CP1252_e: case ASCII_e: case iso646_e: case EBCDIC_e: + case UTF8_e: __gg__low_value_character = DEGENERATE_LOW_VALUE; __gg__high_value_character = DEGENERATE_HIGH_VALUE; gg_call(VOID, "__gg__alphabet_use", + build_int_cst_type(INT, current_encoding(display_encoding_e)), + build_int_cst_type(INT, current_encoding(national_encoding_e)), build_int_cst_type(INT, alphabet.encoding), null_pointer_node, NULL_TREE); @@ -4801,6 +5256,8 @@ parser_alphabet_use( cbl_alphabet_t& alphabet ) gg_call(VOID, "__gg__alphabet_use", + build_int_cst_type(INT, current_encoding(display_encoding_e)), + build_int_cst_type(INT, current_encoding(national_encoding_e)), build_int_cst_type(INT, alphabet.encoding), build_int_cst_type(SIZE_T, alphabet_index), NULL_TREE); @@ -4864,58 +5321,93 @@ parser_display_internal(tree file_descriptor, gg_call(VOID, "__gg__display_string", file_descriptor, + build_int_cst_type(INT, refer.field->codeset.encoding), build_string_literal(refer.field->data.capacity, refer.field->data.initial), build_int_cst_type(SIZE_T, refer.field->data.capacity), advance ? integer_one_node : integer_zero_node, NULL_TREE ); - cursor_at_sol = advance; } else if( refer.field->type == FldLiteralN ) { // The parser found the string of digits from the source code and converted - // it to a _Float128. + // it to a 128-bit binary floating point number. // The bad news is that something like 555.55 can't be expressed exactly; // internally it is 555.5499999999.... - // The good news is that we know any string of 33 or fewer digits is - // converted to _Float128 and then converted back again, you get the same - // string. + // The good news is that we know any string of 33 or fewer decimal digits + // can be converted to and from IEEE 754 binary128 without being changes // We make use of that here char ach[128]; - strfromf128(ach, sizeof(ach), "%.33E", refer.field->data.value_of()); - char *p = strchr(ach, 'E'); + real_to_decimal (ach, TREE_REAL_CST_PTR (refer.field->data.value_of()), + sizeof(ach), 33, 0); + char *p = strchr(ach, 'e'); if( !p ) { // Probably INF -INF NAN or -NAN, so ach has our result + // Except that real_to_decimal prints -0.0 and 0.0 like that with + // no e. + if( ach[0] == '0' || ( ach[0] == '-' && ach[1] == '0' )) + __gg__remove_trailing_zeroes(ach); } else { - p += 1; - int exp = atoi(p); + int exp = atoi(p+1); if( exp >= 6 || exp <= -5 ) { // We are going to stick with the E notation, so ach has our result + // Except that real_to_decimal prints with e notation rather than E + // and doesn't guarantee at least two exponent digits. + *p = 'E'; + if( exp < 0 && exp >= -9 ) + { + p[1] = '-'; + p[2] = '0'; + p[3] = '0' - exp; + p[4] = '\0'; + } + else if( exp >= 0 && exp <= 9 ) + { + p[1] = '+'; + p[2] = '0'; + p[3] = '0' + exp; + p[4] = '\0'; + } } - else + else if (exp == 0) + { + p[-1] = '\0'; + } + else if (exp < 0) + { + p[-1] = '\0'; + char *q = strchr (ach, '.'); + char dig = q[-1]; + q[-1] = '\0'; + char tem[132]; + snprintf (tem, 132, "%s0.%0*d%c%s", ach, -exp - 1, 0, dig, q + 1); + strcpy (ach, tem); + } + else // if (exp > 0) { - int precision = 32 - exp; - char achFormat[24]; - sprintf(achFormat, "%%.%df", precision); - strfromf128(ach, sizeof(ach), achFormat, refer.field->data.value_of()); + p[-1] = '\0'; + char *q = strchr (ach, '.'); + for (int i = 0; i != exp; ++i) + q[i] = q[i + 1]; + q[exp] = '.'; } __gg__remove_trailing_zeroes(ach); } if( symbol_decimal_point() == ',' ) { - char *p = strchr(ach, '.' ); - if( p ) + char *pdot = strchr(ach, '.' ); + if( pdot ) { - *p = symbol_decimal_point(); + *pdot = symbol_decimal_point(); } } @@ -4950,7 +5442,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, @@ -4974,10 +5466,27 @@ parser_display_field(cbl_field_t *field) void parser_display( const struct cbl_special_name_t *upon, - struct cbl_refer_t refs[], - size_t n, - bool advance ) + const std::vector<cbl_refer_t> &refs, + bool advance, + const cbl_label_t *not_error, + const cbl_label_t *error ) { + const size_t n = refs.size(); + /* + * The first parameter to parser_display is the "device" upon which to display + * the data. Besides normal devices, these may include elements that define the + * Unix command line and environment: + * 1. ARG_NUM_e, the ARGUMENT-NUMBER + * 2. ARG_VALUE_e, the ARGUMENT-VALUE + * 3. ENV_NAME_e, the ENVIRONMENT-NAME + * 4. ENV_VALUE_e, the ENVIRONMENT-VALUE + * that need special care and feeding. + */ + + // At the present time, I am not sure what not_error and error are for + gcc_assert(!not_error); + gcc_assert(!error); + Analyze(); SHOW_PARSE { @@ -4986,7 +5495,7 @@ parser_display( const struct cbl_special_name_t *upon, for(size_t i=0; i<n; i++) { SHOW_PARSE_INDENT - SHOW_PARSE_REF("", refs[i]); + SHOW_PARSE_REF("", refs.at(i)); } if( advance ) { @@ -5018,38 +5527,106 @@ parser_display( const struct cbl_special_name_t *upon, { switch(upon->id) { + // See table 5 in the IBM Cobol For Linux x86 1.2 document. + + case STDIN_e: + case SYSIN_e: + case SYSIPT_e: + cbl_internal_error("Attempting to send to an input device."); + break; + + case C01_e: + case C02_e: + case C03_e: + case C04_e: + case C05_e: + case C06_e: + case C07_e: + case C08_e: + case C09_e: + case C10_e: + case C11_e: + case C12_e: + case CSP_e: + case S01_e: + case S02_e: + case S03_e: + case S04_e: + case S05_e: + case AFP_5A_e: + case ARG_VALUE_e: + cbl_internal_error("Not valid for DISPLAY statement."); + break; + case STDOUT_e: - case SYSOUT_e: - case SYSLIST_e: - case SYSLST_e: case CONSOLE_e: + // These are inarguably stdout gg_assign(file_descriptor, integer_one_node); break; case STDERR_e: + case SYSERR_e: + // These are inarguably stderr + gg_assign(file_descriptor, integer_two_node); + break; + + case SYSOUT_e: + case SYSLIST_e: + case SYSLST_e: case SYSPUNCH_e: case SYSPCH_e: - gg_assign(file_descriptor, integer_two_node); + // In the 21st century, when there are no longer valid assumptions to + // be made about the existence of line printers, and where things + // formerly-ubiquitous card punches no longer exist, there is a need + // for the possibility of assigning these "devices" to externally- + // determined Unix gadgetry in /dev: + gg_assign(file_descriptor, + gg_call_expr( INT, + "__gg__get_file_descriptor", + gg_string_literal(upon->os_filename), + NULL_TREE)); + needs_closing = true; break; - default: - if( upon->os_filename[0] ) - { - tree topen = gg_open( gg_string_literal(upon->os_filename), - build_int_cst_type(INT, O_APPEND|O_WRONLY)); - gg_assign(file_descriptor, topen); - needs_closing = true; - } - else - { - fprintf(stderr, "We don't know what to do in parser_display\n"); - gcc_unreachable(); - } + case ARG_NUM_e: + // Set the index number for a subsequent ACCEPT FROM ARG_VALUE_e + gg_call(VOID, + "__gg__set_arg_num", + gg_get_address_of(refs[0].field->var_decl_node), + refer_offset(refs[0]), + refer_size_source(refs[0]), + NULL_TREE); + return; + break; + + case ENV_NAME_e: + // Establish the name of an environment variable for later use with + // in either DISPLAY UPON or ACCEPT FROM + gg_call(VOID, + "__gg__set_env_name", + gg_get_address_of(refs[0].field->var_decl_node), + refer_offset(refs[0]), + refer_size_source(refs[0]), + NULL_TREE); + return; + break; + + case ENV_VALUE_e: + // Set the contents of the environment variable named with ENV_NAME_e + gg_call(VOID, + "__gg__set_env_value", + gg_get_address_of(refs[0].field->var_decl_node), + refer_offset(refs[0]), + refer_size_source(refs[0]), + NULL_TREE); + return; + break; } } else { - gg_assign(file_descriptor,integer_one_node); // stdout is file descriptor 1. + // stdout is file descriptor 1. + gg_assign(file_descriptor, integer_one_node); } for(size_t i=0; i<n-1; i++) @@ -5058,18 +5635,117 @@ parser_display( const struct cbl_special_name_t *upon, parser_display_internal(file_descriptor, refs[i], DISPLAY_NO_ADVANCE); } CHECK_FIELD(refs[n-1].field); - parser_display_internal(file_descriptor, refs[n-1], advance ? DISPLAY_ADVANCE : DISPLAY_NO_ADVANCE); - + parser_display_internal(file_descriptor, + refs[n-1], + advance ? DISPLAY_ADVANCE : DISPLAY_NO_ADVANCE); if( needs_closing ) { - tree tclose = gg_close(file_descriptor); - // We are ignoring the close() return value - gg_append_statement(tclose); + gg_close(file_descriptor); } cursor_at_sol = advance; } +static +bool // Returns false for literals; true for named variables +get_exhibit_name(tree file_descriptor, const cbl_refer_t &arg) + { + bool retval; + if( is_literal(arg.field) ) + { + // If something is a literal, we just display the literal value + parser_display_internal(file_descriptor, + arg, + DISPLAY_NO_ADVANCE); + retval = false; + } + else + { + // It's not a literal, so we show its name, and the names or literal + // values) of any qualifier subscripts or refmods + gg_write( file_descriptor, + gg_string_literal(arg.field->name), + build_int_cst_type(SIZE_T, strlen(arg.field->name)) ); + + if( arg.subscripts.size() ) + { + // This refer has subscripts: + gg_write( file_descriptor, + gg_string_literal("("), + integer_one_node ); + for(size_t i=0; i<arg.subscripts.size(); i++) + { + if( i > 0 ) + { + gg_write( file_descriptor, + gg_string_literal(","), + integer_one_node ); + } + get_exhibit_name(file_descriptor, arg.subscripts[i]); + } + gg_write( file_descriptor, + gg_string_literal(")"), + integer_one_node ); + } + if( arg.refmod.from || arg.refmod.len ) + { + gg_write( file_descriptor, + gg_string_literal("("), + integer_one_node ); + if( arg.refmod.from ) + { + get_exhibit_name(file_descriptor, *(arg.refmod.from)); + } + gg_write( file_descriptor, + gg_string_literal(":"), + integer_one_node ); + if( arg.refmod.len ) + { + get_exhibit_name(file_descriptor, *(arg.refmod.len)); + } + gg_write( file_descriptor, + gg_string_literal(")"), + integer_one_node ); + } + retval = true; + } + return retval; + } + +void +parser_exhibit( bool /*changed*/, bool /*named*/, + const std::vector<cbl_refer_t> &args ) + { + tree file_descriptor = gg_define_int(); + gg_assign(file_descriptor, integer_one_node); // stdout is file descriptor 1. + + for(size_t i=0; i<args.size(); i++) + { + CHECK_FIELD(args[i].field); + if(i > 0) + { + // When there more than one argument, the second through Nth get a space + // in front of them. + gg_write( file_descriptor, + gg_string_literal(" "), + integer_one_node); + } + if( get_exhibit_name(file_descriptor, args[i]) ) + { + gg_write( file_descriptor, + gg_string_literal("="), + integer_one_node); + parser_display_internal(file_descriptor, + args[i], + DISPLAY_NO_ADVANCE); + } + } + gg_write( file_descriptor, + gg_string_literal("\n"), + integer_one_node); + cursor_at_sol = true; + } + static tree get_literalN_value(cbl_field_t *var) { @@ -5104,7 +5780,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 ) { @@ -5123,7 +5800,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); } @@ -5340,12 +6018,12 @@ parser_assign( size_t nC, cbl_num_result_t *C, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT(" Laying down on_error GOTO into") - SHOW_PARSE_LABEL(" ", on_error) + SHOW_PARSE_LABEL_OK(" ", on_error) } IF( gg_bitwise_or(error_flag, compute_error->structs.compute_error->compute_error_code), - ne_op, - integer_zero_node ) + ne_op, + integer_zero_node ) { gg_append_statement( on_error->structs.arith_error->into.go_to ); } @@ -5371,7 +6049,7 @@ parser_assign( size_t nC, cbl_num_result_t *C, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT(" Laying down not_error GOTO into") - SHOW_PARSE_LABEL(" ", not_error) + SHOW_PARSE_LABEL_OK(" ", not_error) } IF( compute_error->structs.compute_error->compute_error_code, eq_op, integer_zero_node ) { @@ -5387,7 +6065,7 @@ parser_assign( size_t nC, cbl_num_result_t *C, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT(" Laying down on_error LABEL BOTTOM:") - SHOW_PARSE_LABEL(" ", on_error) + SHOW_PARSE_LABEL_OK(" ", on_error) } gg_append_statement( on_error->structs.arith_error->bottom.label ); } @@ -5398,7 +6076,7 @@ parser_assign( size_t nC, cbl_num_result_t *C, { SHOW_PARSE_INDENT SHOW_PARSE_TEXT(" Laying down not_error LABEL BOTTOM:") - SHOW_PARSE_LABEL(" ", not_error) + SHOW_PARSE_LABEL_OK(" ", not_error) } gg_append_statement( not_error->structs.arith_error->bottom.label ); } @@ -5410,16 +6088,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 @@ -5673,16 +6351,24 @@ parser_initialize_table(size_t nelem, } typedef size_t span_t[2]; static_assert(sizeof(spans[0]) == sizeof(span_t), "pair size wrong"); - static tree tspans = gg_define_variable(SIZE_T_P, "..pit_v1", vs_file_static); - static tree ttbls = gg_define_variable(SIZE_T_P, "..pit_v2", vs_file_static); - gg_assign(tspans, build_array_of_size_t(2*nspan, (const size_t *)spans)); - gg_assign(ttbls, build_array_of_size_t(2*ntbl, (const size_t *)tbls)); + static tree tspans = gg_define_variable(SIZE_T_P, + "..pit_v1", + vs_file_static); + static tree ttbls = gg_define_variable(SIZE_T_P, + "..pit_v2", +vs_file_static); + gg_assign(tspans, + build_array_of_size_t(2*nspan, + reinterpret_cast<const size_t *>(spans))); + gg_assign(ttbls, + build_array_of_size_t(2*ntbl, + reinterpret_cast<const size_t *>(tbls))); gg_call(VOID, "__gg__mirror_range", 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), @@ -5720,7 +6406,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; @@ -5773,19 +6459,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; } @@ -5801,24 +6487,25 @@ 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: case FldForward: case FldSwitch: case FldDisplay: - case FldBlob: return false; // These are variable types that have to be converted from their // 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: @@ -5829,22 +6516,22 @@ is_valuable( cbl_field_type_t type ) { case FldPointer: return true; } - cbl_internal_error( "%s:%d: invalid symbol_type_t %d", __func__, __LINE__, type ); + cbl_internal_error( "%s:%d: invalid %<symbol_type_t%> %d", __func__, __LINE__, type ); return false; } -void parser_sleep(cbl_refer_t seconds) +void parser_sleep(const cbl_refer_t &seconds) { if( seconds.field ) { 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); } @@ -5853,7 +6540,7 @@ void parser_sleep(cbl_refer_t seconds) // This is a naked place-holding CONTINUE. Generate some do-nothing // code that will stick some .LOC information into the assembly language, // so that GDB-COBOL can display the CONTINUE statement. - gg_assign(var_decl_nop, build_int_cst_type(INT, 103)); + insert_nop(103); } } @@ -5873,7 +6560,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;". @@ -5896,9 +6583,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. @@ -5939,12 +6623,12 @@ pe_stuff(cbl_refer_t refer, ec_type_t ec) tree array_type = build_array_type_nelts(UCHAR, returner->data.capacity); - tree retval = gg_define_variable(array_type, vs_static); - gg_memcpy(gg_get_address_of(retval), + tree array = gg_define_variable(array_type, vs_static); + gg_memcpy(gg_get_address_of(array), member(returner->var_decl_node, "data"), member(returner->var_decl_node, "capacity")); - tree actual = gg_cast(COBOL_FUNCTION_RETURN_TYPE, gg_get_address_of(retval)); + tree actual = gg_cast(COBOL_FUNCTION_RETURN_TYPE, gg_get_address_of(array)); restore_local_variables(); gg_return(actual); @@ -5964,7 +6648,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 @@ -6001,7 +6685,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 { @@ -6012,7 +6696,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 { @@ -6037,7 +6721,7 @@ parser_exit( cbl_refer_t refer, ec_type_t ec ) { } ENDIF - pe_stuff(refer, ec); + program_end_stuff(refer, ec); } } @@ -6147,19 +6831,19 @@ parser_allocate(cbl_refer_t size_or_based, cbl_field_t *f_working = current_options().initial_working(); cbl_field_t *f_local = current_options().initial_local(); - int default_byte = wsclear() ? *wsclear() : -1; + unsigned int default_byte = wsclear() ? *wsclear() : (uint32_t)(-1); 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); @@ -6177,20 +6861,175 @@ 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); } } +static +cbl_label_addresses_t * +label_fetch(struct cbl_label_t *label) + { + if( !label->structs.goto_trees ) + { + label->structs.goto_trees + = static_cast<cbl_label_addresses_t *> + (xmalloc(sizeof(struct cbl_label_addresses_t))); + gcc_assert(label->structs.goto_trees); + + gg_create_goto_pair(&label->structs.goto_trees->go_to, + &label->structs.goto_trees->label); + } + return label->structs.goto_trees; + } + +void +parser_xml_parse( cbl_label_t *instance, + cbl_refer_t input, + cbl_field_t *encoding, + cbl_field_t *validating, + bool returns_national, + cbl_label_t *from_proc, + cbl_label_t *to_proc ) + { + SHOW_PARSE + { + SHOW_PARSE_HEADER + SHOW_PARSE_LABEL_OK("", instance) + SHOW_PARSE_REF(" ", input) + SHOW_PARSE_END + } + + TRACE1 + { + TRACE1_HEADER + TRACE1_END + } + + // We know that this routine comes first in the sequence, so we can + // create the goto/label pairs here: + + instance->structs.xml_parse = static_cast<struct cbl_xml_parse_t *> + (xmalloc(sizeof(struct cbl_xml_parse_t))); + gcc_assert(instance->structs.xml_parse); + + gg_create_goto_pair(&instance->structs.xml_parse->over.go_to, + &instance->structs.xml_parse->over.label); + gg_create_goto_pair(&instance->structs.xml_parse->exception.go_to, + &instance->structs.xml_parse->exception.label); + gg_create_goto_pair(&instance->structs.xml_parse->no_exception.go_to, + &instance->structs.xml_parse->no_exception.label); + + // We need to create a COBOL ENTRY point into this function. That entry + // point will be used by __gg__xml_parse to perform from_proc through to_proc + // as part of processing the libxml2 callbacks. + + char ach[64]; + static int instance_counter = 1; + sprintf(ach, + "_%s_xml_callback_%d", + current_function->our_name, + instance_counter++); + + cbl_field_t for_entry = {}; + for_entry.type = FldAlphanumeric; + for_entry.data.capacity = strlen(ach); + for_entry.data.initial = ach; + for_entry.codeset.encoding = iconv_CP1252_e; + + // build an island for the callback: + tree island_goto; + tree island_label; + gg_create_goto_pair(&island_goto, + &island_label); + + gg_append_statement(island_goto); + // This creates the separate _xml_callback function + parser_entry(&for_entry, 0, nullptr); + // When invoked, the callback performs the processing procedures + parser_perform(from_proc, to_proc); + // And then returns back to the caller + gg_return(0); + gg_append_statement(island_label); + + // With the callback in place, we are ready to call the library: + tree pcallback = gg_get_function_address(VOID, ach); + + tree erc = gg_define_int(); + gg_assign(erc, gg_call_expr(INT, + "__gg__xml_parse", + gg_get_address_of(input.field->var_decl_node), + refer_offset(input), + refer_size_source(input), + encoding ? + gg_get_address_of(encoding->var_decl_node) + : null_pointer_node, + validating ? + gg_get_address_of(validating->var_decl_node) + : null_pointer_node, + build_int_cst_type(INT, returns_national), + pcallback, + NULL_TREE)); + IF( erc, ne_op, integer_zero_node ) + { + //gg_printf("__gg__xml_parse() failed with erc %d\n", erc, NULL_TREE); + gg_append_statement(instance->structs.xml_parse->exception.go_to); + } + ELSE + { + //gg_printf("__gg__xml_parse() apparently succeeded\n", NULL_TREE); + gg_append_statement(instance->structs.xml_parse->no_exception.go_to); + } + ENDIF + } + +void +parser_xml_on_exception( cbl_label_t *instance ) + { + SHOW_PARSE + { + SHOW_PARSE_HEADER + SHOW_PARSE_LABEL_OK(" ", instance) + SHOW_PARSE_END + } + gg_append_statement(instance->structs.xml_parse->over.go_to); + gg_append_statement(instance->structs.xml_parse->exception.label); + } + +void +parser_xml_not_exception( cbl_label_t *instance ) +{ + SHOW_PARSE + { + SHOW_PARSE_HEADER + SHOW_PARSE_LABEL_OK(" ", instance) + SHOW_PARSE_END + } + gg_append_statement(instance->structs.xml_parse->over.go_to); + gg_append_statement(instance->structs.xml_parse->no_exception.label); + } + +void parser_xml_end( cbl_label_t *instance ) + { + SHOW_PARSE + { + SHOW_PARSE_HEADER + SHOW_PARSE_LABEL_OK(" ", instance) + SHOW_PARSE_END + } + gg_append_statement(instance->structs.xml_parse->over.label); + } + void parser_arith_error(cbl_label_t *arithmetic_label) { @@ -6199,7 +7038,6 @@ parser_arith_error(cbl_label_t *arithmetic_label) // We are entering either SIZE ERROR or NOT SIZE ERROR code RETURN_IF_PARSE_ONLY; - set_up_on_exception_label(arithmetic_label); SHOW_PARSE { @@ -6212,6 +7050,10 @@ parser_arith_error(cbl_label_t *arithmetic_label) SHOW_PARSE_END } + CHECK_LABEL(arithmetic_label); + + set_up_on_exception_label(arithmetic_label); + // Jump over the [NOT] ON EXCEPTION code that is about to be laid down gg_append_statement( arithmetic_label->structs.arith_error->over.go_to ); // Create the label that allows the following code to be executed at @@ -6238,6 +7080,8 @@ parser_arith_error_end(cbl_label_t *arithmetic_label) SHOW_PARSE_END } + CHECK_LABEL(arithmetic_label); + // Jump to the end of the arithmetic code: gg_append_statement( arithmetic_label->structs.arith_error->bottom.go_to ); // Lay down the label that allows the ERROR/NOT ERROR instructions @@ -6317,9 +7161,10 @@ initialize_the_data() // This is one-time initialization of the libgcobol program state stack gg_call(VOID, "__gg__init_program_state", + build_int_cst_type(INT, current_encoding(display_encoding_e)), + build_int_cst_type(INT, current_encoding(national_encoding_e)), NULL_TREE); - __gg__currency_signs = __gg__ct_currency_signs; // We initialize currency both at compile time and run time __gg__currency_sign_init(); gg_call(VOID, @@ -6368,6 +7213,280 @@ initialize_the_data() } } +static +void +establish_using(size_t nusing, + cbl_ffi_arg_t args[] ) + { + if( nusing ) + { + for(size_t i=0; i<nusing; i++) + { + // This code is relevant at compile time. It takes each + // expected formal parameter and tacks it onto the end of the + // function's arguments chain. + + char *ach = xasprintf("_p_%s", args[i].refer.field->name); + + size_t nbytes = 0; + tree par_type = tree_type_from_field_type(args[i].refer.field, nbytes); + if( par_type == FLOAT ) + { + par_type = SSIZE_T; + } + if( par_type == DOUBLE ) + { + par_type = SSIZE_T; + } + if( par_type == FLOAT128 ) + { + par_type = INT128; + } + chain_parameter_to_function(current_function->function_decl, par_type, ach); + free(ach); + } + + // During the call, we saved the parameter_count and an array of variable + // lengths. We need to look at those values if, and only if, one or more + // of our USING arguments has an OPTIONAL flag or if one of our targets is + // marked as VARYING. + bool check_for_parameter_count = false; + for(size_t i=0; i<nusing; i++) + { + if( args[i].optional ) + { + check_for_parameter_count = true; + break; + } + if( args[i].refer.field->attr & any_length_e ) + { + check_for_parameter_count = true; + break; + } + } + + if( check_for_parameter_count ) + { + IF( var_decl_call_parameter_signature, + eq_op, + gg_cast(CHAR_P, current_function->function_address) ) + { + // We know to use var_decl_call_parameter_count, so unflag this + // pointer to avoid problems in the ridiculous possibility of + // COBOL-A calls C_B calls COBOL_A + gg_assign(var_decl_call_parameter_signature, + gg_cast(CHAR_P, null_pointer_node)); + } + ELSE + { + // We were apparently called by a C routine, not a COBOL routine, so + // make sure we don't get shortchanged by a count left behind from an + // earlier COBOL call. + gg_assign(var_decl_call_parameter_count, + build_int_cst_type(INT, A_ZILLION)); + } + ENDIF + } + else + { + // None of our parameters require a count, so make sure we don't get + // bamboozled by a count left behind from an earlier COBOL call. + gg_assign(var_decl_call_parameter_count, + build_int_cst_type(INT, A_ZILLION)); + } + + // There are 'nusing' elements in the PROCEDURE DIVISION USING list. + + tree parameter = NULL_TREE; + tree rt_i = gg_define_int(); + for(size_t i=0; i<nusing; i++) + { + // And this compiler code generates run-time execution code. The + // generated code picks up, at run time, the variable we just + // established in the chain at compile time. + + // It makes more sense if you don't think about it too hard. + + // We need to be able to restore prior arguments when doing recursive + // calls: + IF( member(args[i].refer.field->var_decl_node, "data"), + ne_op, + gg_cast(UCHAR_P, null_pointer_node) ) + { + gg_call(VOID, + "__gg__push_local_variable", + gg_get_address_of(args[i].refer.field->var_decl_node), + NULL_TREE); + } + ELSE + ENDIF + + tree base = gg_define_variable(UCHAR_P); + gg_assign(rt_i, build_int_cst_type(INT, i)); + //gg_printf("The rt_i counter is %d\n", rt_i, NULL_TREE); + IF( rt_i, lt_op , var_decl_call_parameter_count ) + { + if( i == 0 ) + { + // This is the first parameter. + parameter = DECL_ARGUMENTS(current_function->function_decl); + } + else + { + // These are subsequent parameters + parameter = TREE_CHAIN(parameter); + } + gg_assign(base, gg_cast(UCHAR_P, parameter)); + + if( args[i].refer.field->attr & any_length_e ) + { + // 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), + // NULL_TREE); + + // Get the length from the global lengths[] side channel. Don't + // forget to use the length mask on the table value. + gg_assign(member(args[i].refer.field->var_decl_node, "capacity"), + gg_array_value(var_decl_call_parameter_lengths, rt_i)); + } + } + ELSE + { + gg_assign(base, gg_cast(UCHAR_P, null_pointer_node)); + } + ENDIF + + // Arriving here means that we are processing an instruction like + // this: + // PROCEDURE DIVISION USING using[0] using[1] ... using using[nusing-1] + + // When __gg__call_parameter_count is equal to A_ZILLION, then this is + // an OTHER-TO-COBOL call and the var_decl_call_parameter_lengths array + // is not valid + + cbl_ffi_crv_t crv = args[i].crv; + cbl_field_t *new_var = args[i].refer.field; + + if( crv == by_value_e ) + { + switch(new_var->type) + { + case FldGroup: + case FldAlphanumeric: + case FldAlphaEdited: + case FldNumericEdited: + crv = by_reference_e; + break; + default: + break; + } + } + + if( crv == by_value_e ) + { + // 'parameter' is the 64-bit or 128-bit value that was placed on the stack + + size_t nbytes; + tree_type_from_field_type(new_var, nbytes); + tree parm = gg_define_variable(INT128); + + if( nbytes <= 8 ) + { + // Our input is a 64-bit number + if( new_var->attr & signable_e ) + { + IF( gg_bitwise_and( gg_cast(SIZE_T, base), + build_int_cst_type(SIZE_T, 0x8000000000000000ULL)), + ne_op, + gg_cast(SIZE_T, integer_zero_node) ) + { + // Our input is a negative number + gg_assign(parm, gg_cast(INT128, integer_minus_one_node)); + } + ELSE + { + // Our input is a positive number + gg_assign(parm, gg_cast(INT128, integer_zero_node)); + } + ENDIF + } + else + { + // This is a 64-bit positive number: + gg_assign(parm, gg_cast(INT128, integer_zero_node)); + } + } + // At this point, parm has been set to 0 or -1 + + gg_memcpy(gg_get_address_of(parm), + gg_get_address_of(base), + build_int_cst_type(SIZE_T, nbytes)); + + tree array_type = build_array_type_nelts(UCHAR, new_var->data.capacity); + tree data_decl_node = gg_define_variable( array_type, + NULL, + vs_static); + gg_assign( member(new_var->var_decl_node, "data"), + gg_get_address_of(data_decl_node) ); + + // And then move it into place + gg_call(VOID, + "__gg__assign_value_from_stack", + gg_get_address_of(new_var->var_decl_node), + parm, + NULL_TREE); + // We now have to handle an oddball situation. It's possible we are + // dealing with + // + // linkage section. + // 01 var1 + // 01 var2 redefines var1 + // + // If so, we have to give var2::data_pointer the same value as + // var1::data_pointer + // + size_t our_index = symbol_index(symbol_elem_of(new_var)); + size_t next_index = our_index + 1; + // Look ahead in the symbol table for the next LEVEL01/77 + for(;;) + { + symbol_elem_t *e = symbol_at(next_index); + if( e->type != SymField ) + { + break; + } + cbl_field_t *next_var = cbl_field_of(e); + if( !next_var ) + { + break; + } + if( next_var->level == LEVEL01 || next_var->level == LEVEL77 ) + { + if( next_var->parent == our_index ) + { + gg_assign(member(next_var->var_decl_node, "data"), + member(new_var->var_decl_node, "data")); + } + break; + } + next_index += 1; + } + } + else + { + // 'parameter' is a reference, so it it becomes the data member of + // the cblc_field_t COBOL variable. + gg_assign(member(args[i].field()->var_decl_node, "data"), base); + + // We need to apply base + offset to the LINKAGE variable + // and all of its children + propogate_linkage_offsets( args[i].field(), base ); + } + } + } + } + void parser_division(cbl_division_t division, cbl_field_t *returning, @@ -6421,8 +7540,6 @@ parser_division(cbl_division_t division, SHOW_PARSE_END } - gg_set_current_line_number(CURRENT_LINE_NUMBER); - if( division == data_div_e ) { Analyze(); @@ -6451,8 +7568,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); @@ -6464,8 +7581,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, @@ -6501,7 +7618,7 @@ parser_division(cbl_division_t division, // UPSI 10000110 means that bits 0, 5, and 6 are on, which means that // SW-0, SW-5, and SW-6 are on. gg_call(VOID, - "__gg__set_initial_switch_value", + "__gg__onetime_initialization", NULL_TREE); // And then flag one-time initialization as having been done. @@ -6527,7 +7644,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 @@ -6548,6 +7665,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() @@ -6564,289 +7685,6 @@ parser_division(cbl_division_t division, // length. We establish those lengths based on the types of the target // for each USING. - for(size_t i=0; i<nusing; i++) - { - // This code is relevant at compile time. It takes each - // expected formal parameter and tacks it onto the end of the - // function's arguments chain. - - char ach[2*sizeof(cbl_name_t)]; - sprintf(ach, "_p_%s", args[i].refer.field->name); - - size_t nbytes = 0; - tree par_type = tree_type_from_field_type(args[i].refer.field, nbytes); - if( par_type == FLOAT ) - { - par_type = SSIZE_T; - } - if( par_type == DOUBLE ) - { - par_type = SSIZE_T; - } - if( par_type == FLOAT128 ) - { - par_type = INT128; - } - chain_parameter_to_function(current_function->function_decl, par_type, ach); - } - - bool check_for_parameter_count = false; - - if( nusing ) - { - // During the call, we saved the parameter_count and an array of variable - // lengths. We need to look at those values if, and only if, one or more - // of our USING arguments has an OPTIONAL flag or if one of our targets is - // marked as VARYING. - for(size_t i=0; i<nusing; i++) - { - if( args[i].optional ) - { - check_for_parameter_count = true; - break; - } - if( args[i].refer.field->attr & any_length_e ) - { - check_for_parameter_count = true; - break; - } - } - - if( check_for_parameter_count ) - { - IF( var_decl_call_parameter_signature, - eq_op, - gg_cast(CHAR_P, current_function->function_address) ) - { - // We know to use var_decl_call_parameter_count, so unflag this - // pointer to avoid problems in the ridiculous possibility of - // COBOL-A calls C_B calls COBOL_A - gg_assign(var_decl_call_parameter_signature, - gg_cast(CHAR_P, null_pointer_node)); - } - ELSE - { - // We were apparently called by a C routine, not a COBOL routine, so - // make sure we don't get shortchanged by a count left behind from an - // earlier COBOL call. - gg_assign(var_decl_call_parameter_count, - build_int_cst_type(INT, A_ZILLION)); - } - ENDIF - } - else - { - // None of our parameters require a count, so make sure we don't get - // bamboozled by a count left behind from an earlier COBOL call. - gg_assign(var_decl_call_parameter_count, - build_int_cst_type(INT, A_ZILLION)); - } - - // There are 'nusing' elements in the PROCEDURE DIVISION USING list. - - tree parameter; - tree rt_i = gg_define_int(); - for(size_t i=0; i<nusing; i++) - { - // And this compiler code generates run-time execution code. The - // generated code picks up, at run time, the variable we just - // established in the chain at compile time. - - // It makes more sense if you don't think about it too hard. - - // We need to be able to restore prior arguments when doing recursive - // calls: - IF( member(args[i].refer.field->var_decl_node, "data"), - ne_op, - gg_cast(UCHAR_P, null_pointer_node) ) - { - gg_call(VOID, - "__gg__push_local_variable", - gg_get_address_of(args[i].refer.field->var_decl_node), - NULL_TREE); - } - ELSE - ENDIF - - tree base = gg_define_variable(UCHAR_P); - gg_assign(rt_i, build_int_cst_type(INT, i)); - //gg_printf("The rt_i counter is %d\n", rt_i, NULL_TREE); - IF( rt_i, lt_op , var_decl_call_parameter_count ) - { - if( i == 0 ) - { - // This is the first parameter. - parameter = DECL_ARGUMENTS(current_function->function_decl); - } - else - { - // These are subsequent parameters - parameter = TREE_CHAIN(parameter); - } - 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 0x%lx\n", gg_array_value(var_decl_call_parameter_lengths, rt_i), NULL_TREE); - - // Get the length from the global lengths[] side channel. Don't - // forget to use the length mask on the table value. - gg_assign(member(args[i].refer.field->var_decl_node, "capacity"), - gg_array_value(var_decl_call_parameter_lengths, rt_i)); - } - } - ELSE - { - gg_assign(base, gg_cast(UCHAR_P, null_pointer_node)); - } - ENDIF - - // Arriving here means that we are processing an instruction like - // this: - // PROCEDURE DIVISION USING using[0] using[1] ... using using[nusing-1] - - // When __gg__call_parameter_count is equal to A_ZILLION, then this is - // an OTHER-TO-COBOL call and the var_decl_call_parameter_lengths array - // is not valid - - cbl_ffi_crv_t crv = args[i].crv; - cbl_field_t *new_var = args[i].refer.field; - - if( crv == by_value_e ) - { - switch(new_var->type) - { - case FldGroup: - case FldAlphanumeric: - case FldAlphaEdited: - case FldNumericEdited: - crv = by_reference_e; - break; - default: - break; - } - } - - if( crv == by_value_e ) - { - // 'parameter' is the 64-bit or 128-bit value that was placed on the stack - - size_t nbytes; - tree_type_from_field_type(new_var, nbytes); - tree parm = gg_define_variable(INT128); - - if( nbytes <= 8 ) - { - // Our input is a 64-bit number - if( new_var->attr & signable_e ) - { - IF( gg_bitwise_and( gg_cast(SIZE_T, base), - build_int_cst_type(SIZE_T, 0x8000000000000000ULL)), - ne_op, - gg_cast(SIZE_T, integer_zero_node) ) - { - // Our input is a negative number - gg_assign(parm, gg_cast(INT128, integer_minus_one_node)); - } - ELSE - { - // Our input is a positive number - gg_assign(parm, gg_cast(INT128, integer_zero_node)); - } - ENDIF - } - else - { - // This is a 64-bit positive number: - gg_assign(parm, gg_cast(INT128, integer_zero_node)); - } - } - // At this point, parm has been set to 0 or -1 - - gg_memcpy(gg_get_address_of(parm), - gg_get_address_of(base), - build_int_cst_type(SIZE_T, nbytes)); - - tree array_type = build_array_type_nelts(UCHAR, new_var->data.capacity); - tree data_decl_node = gg_define_variable( array_type, - NULL, - vs_static); - gg_assign( member(new_var->var_decl_node, "data"), - gg_get_address_of(data_decl_node) ); - - // And then move it into place - gg_call(VOID, - "__gg__assign_value_from_stack", - gg_get_address_of(new_var->var_decl_node), - parm, - NULL_TREE); - // We now have to handle an oddball situation. It's possible we are - // dealing with - // - // linkage section. - // 01 var1 - // 01 var2 redefines var1 - // - // If so, we have to give var2::data_pointer the same value as - // var1::data_pointer - // - cbl_field_t *next_var; - size_t our_index = symbol_index(symbol_elem_of(new_var)); - size_t next_index = our_index + 1; - // Look ahead in the symbol table for the next LEVEL01/77 - for(;;) - { - symbol_elem_t *e = symbol_at(next_index); - if( e->type != SymField ) - { - break; - } - next_var = cbl_field_of(e); - if( !next_var ) - { - break; - } - if( next_var->level == LEVEL01 || next_var->level == LEVEL77 ) - { - if( next_var->parent == our_index ) - { - gg_assign(member(next_var->var_decl_node, "data"), - member(new_var->var_decl_node, "data")); - } - break; - } - next_index += 1; - } - } - else - { - // 'parameter' is a reference, so it it becomes the data member of - // the cblc_field_t COBOL variable. - gg_assign(member(args[i].field()->var_decl_node, "data"), base); - - // We need to apply base + offset to the LINKAGE variable - // and all of its children - propogate_linkage_offsets( args[i].field(), base ); - } - } - } - gg_call(VOID, "__gg__pseudo_return_bookmark", NULL_TREE); @@ -6892,6 +7730,30 @@ parser_division(cbl_division_t division, ENDIF } ENDIF + // The first token_location that the parser establishes is caused by the + // parser scanning all of the lines in the source code. This messes up the + // logic for backing up one line, which is needed to correctly step through + // COBOL code with GDB-COBOL. So, we clear it here. + current_location_minus_one_clear(); + + // It is at this point that we check to see if the call to this function + // is a re-entry because of an ENTRY statement: + + IF( var_decl_entry_label, ne_op, null_pointer_node ) + { + // This is an ENTRY re-entry. The processing of USING variables was + // done in parser_entry, so now we jump to the label + static tree loc = gg_define_variable(VOID_P, vs_static); + gg_assign(loc, var_decl_entry_label); + gg_assign(var_decl_entry_label, gg_cast(VOID_P, null_pointer_node)); + gg_goto(loc); + } + ELSE + { + } + ENDIF + + establish_using(nusing, args); } } @@ -6987,20 +7849,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); } @@ -7106,9 +7968,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); @@ -7170,8 +8032,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); } @@ -7180,8 +8042,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)); @@ -7216,8 +8077,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); } @@ -7302,7 +8163,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, "") @@ -7329,21 +8190,6 @@ parser_see_stop_run(struct cbl_refer_t exit_status, gg_exit(returned_value); } -static -cbl_label_addresses_t * -label_fetch(struct cbl_label_t *label) - { - if( !label->structs.goto_trees ) - { - label->structs.goto_trees - = (cbl_label_addresses_t *)xmalloc(sizeof(struct cbl_label_addresses_t) ); - - gg_create_goto_pair(&label->structs.goto_trees->go_to, - &label->structs.goto_trees->label); - } - return label->structs.goto_trees; - } - void parser_label_label(struct cbl_label_t *label) { @@ -7354,15 +8200,18 @@ parser_label_label(struct cbl_label_t *label) SHOW_PARSE_HEADER SHOW_PARSE_LABEL("", label) char ach[32]; - sprintf(ach, " label is at %p", (void*)label); + sprintf(ach, " label is at %p", static_cast<void*>(label)); SHOW_PARSE_TEXT(ach) - sprintf(ach, " label->proc is %p", (void*)label->structs.proc); + if( label ) + { + sprintf(ach, + " label->proc is %p", + static_cast<void*>(label->structs.proc)); + } SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } - CHECK_LABEL(label); - TRACE1 { TRACE1_HEADER @@ -7370,6 +8219,10 @@ parser_label_label(struct cbl_label_t *label) TRACE1_END } + CHECK_LABEL(label); + + label_verify.lay(label); + if(strcmp(label->name, "_end_declaratives") == 0 ) { suppress_cobol_entry_point = false; @@ -7381,21 +8234,25 @@ void parser_label_goto(struct cbl_label_t *label) { label->used = yylineno; + Analyze(); SHOW_PARSE { SHOW_PARSE_HEADER SHOW_PARSE_LABEL(" ", label) char ach[32]; - sprintf(ach, " label is at %p", (void*)label); + sprintf(ach, " label is at %p", static_cast<void*>(label)); SHOW_PARSE_TEXT(ach) - sprintf(ach, " label->proc is %p", (void*)label->structs.proc); + if( label ) + { + sprintf(ach, + " label->proc is %p", + static_cast<void*>(label->structs.proc)); + } SHOW_PARSE_TEXT(ach) SHOW_PARSE_END } - CHECK_LABEL(label); - TRACE1 { TRACE1_HEADER @@ -7403,7 +8260,13 @@ parser_label_goto(struct cbl_label_t *label) TRACE1_END } - if(strcmp(label->name, "_end_declaratives") == 0 ) + CHECK_LABEL(label); + + label_verify.go_to(label); + + label_verify.go_to(label); + + if( strcmp(label->name, "_end_declaratives") == 0 ) { suppress_cobol_entry_point = true; } @@ -7462,25 +8325,26 @@ parser_setop( struct cbl_field_t *tgt, member(candidate, "data"), member(candidate, "capacity"), member(domain, "initial"), + build_int_cst_type(INT, + domain->codeset.encoding), NULL_TREE), ne_op, 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; } @@ -7488,7 +8352,7 @@ parser_setop( struct cbl_field_t *tgt, void parser_classify( cbl_field_t *tgt, - cbl_refer_t candidate, + const cbl_refer_t &candidate, enum classify_t type ) { Analyze(); @@ -7517,7 +8381,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, @@ -7533,9 +8397,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() ) { @@ -7585,14 +8449,6 @@ create_iline_address_pairs(struct cbl_perform_tgt_t *tgt) gg_create_goto_pair(&tgt->addresses.setup.go_to, &tgt->addresses.setup.label); - - // Even in -O0 compilations, the compiler does some elementary optimizations - // around JMP instructions. We have the SETUP code for in-line performats - // in an island at the end of the loop code. With this intervention, NEXTing - // through the code shows you the final statement of the loop before the - // loop actually starts. - - tgt->addresses.line_number_of_setup_code = gg_get_current_line_number(); } void @@ -7606,7 +8462,7 @@ parser_perform_start( struct cbl_perform_tgt_t *tgt ) { SHOW_PARSE_TEXT(" cbl_perform_tgt_t is at") char ach[32]; - sprintf(ach, " %p", (void*)tgt); + sprintf(ach, " %p", static_cast<void*>(tgt)); SHOW_PARSE_TEXT(ach); SHOW_PARSE_LABEL(" ", tgt->from()) if( tgt->to() ) @@ -7655,7 +8511,7 @@ parser_perform_start( struct cbl_perform_tgt_t *tgt ) // Give GDB-COBOL something to chew on when NEXTing. This instruction will // get the line number of the PERFORM N TIMES code. gg_append_statement(tgt->addresses.top.label); - gg_assign(var_decl_nop, build_int_cst_type(INT, 104)); + insert_nop(104); } void @@ -7667,17 +8523,18 @@ parser_perform_conditional( struct cbl_perform_tgt_t *tgt ) SHOW_PARSE_HEADER SHOW_PARSE_TEXT(" cbl_perform_tgt_t is at") char ach[32]; - sprintf(ach, " %p", (void*)tgt); + sprintf(ach, " %p", static_cast<void*>(tgt)); SHOW_PARSE_TEXT(ach); SHOW_PARSE_END } - size_t i = tgt->addresses.number_of_conditionals; + unsigned int i = tgt->addresses.number_of_conditionals; if( !(i < MAXIMUM_UNTILS) ) { - cbl_internal_error("%s:%d: %zu exceeds MAXIMUM_UNTILS of %d, line %d", - __func__, __LINE__, i, MAXIMUM_UNTILS, CURRENT_LINE_NUMBER); + cbl_internal_error("%s:%d: %u exceeds %<MAXIMUM_UNTILS%> of %d, line %d", + __func__, __LINE__, + i, MAXIMUM_UNTILS, CURRENT_LINE_NUMBER); } gcc_assert(i < MAXIMUM_UNTILS); @@ -7716,12 +8573,12 @@ parser_perform_conditional_end( struct cbl_perform_tgt_t *tgt ) SHOW_PARSE_HEADER SHOW_PARSE_TEXT(" cbl_perform_tgt_t is at") char ach[32]; - sprintf(ach, " %p", (void*)tgt); + sprintf(ach, " %p", static_cast<void*>(tgt)); SHOW_PARSE_TEXT(ach); SHOW_PARSE_END } - size_t i = tgt->addresses.number_of_conditionals; + unsigned int i = tgt->addresses.number_of_conditionals; gcc_assert(i); // We need to cap off the prior conditional in this chain of conditionals @@ -7781,8 +8638,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); @@ -7804,8 +8661,9 @@ 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); + token_location_override(current_location_minus_one()); gg_insert_into_assembler( ach ); } @@ -7836,8 +8694,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); @@ -7867,8 +8725,9 @@ 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); + token_location_override(current_location_minus_one()); gg_insert_into_assembler( ach ); } @@ -7932,8 +8791,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); @@ -7987,8 +8846,9 @@ 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); + token_location_override(current_location_minus_one()); gg_insert_into_assembler( ach ); } @@ -8049,8 +8909,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: @@ -8130,8 +8990,9 @@ 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); + token_location_override(current_location_minus_one()); gg_insert_into_assembler( ach ); } @@ -8211,8 +9072,6 @@ perform_inline_until( struct cbl_perform_tgt_t *tgt, GOTO TOP EXIT: */ - gg_set_current_line_number(cobol_location().last_line); - gg_append_statement(tgt->addresses.test.label); // Go to where the conditional is recalculated.... @@ -8327,8 +9186,6 @@ perform_inline_testbefore_varying( struct cbl_perform_tgt_t *tgt, parser_move(varys[i].varying, varys[i].from); } - gg_set_current_line_number(cobol_location().last_line); - // Lay down the testing cycle: for(size_t i=0; i<N; i++) { @@ -8338,7 +9195,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 } @@ -8349,7 +9206,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 } @@ -8360,7 +9218,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 } @@ -8395,7 +9254,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 } @@ -8429,7 +9289,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 } @@ -8446,7 +9307,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 } @@ -8635,7 +9497,7 @@ parser_perform_until( struct cbl_perform_tgt_t *tgt, SHOW_PARSE_HEADER SHOW_PARSE_TEXT(" cbl_perform_tgt_t is at") char ach[32]; - sprintf(ach, " %p", (void*)tgt); + sprintf(ach, " %p", static_cast<void*>(tgt)); SHOW_PARSE_TEXT(ach); SHOW_PARSE_LABEL(" ", tgt->from()) if( tgt->to() ) @@ -8645,9 +9507,6 @@ parser_perform_until( struct cbl_perform_tgt_t *tgt, SHOW_PARSE_END } - gg_set_current_line_number(cobol_location().last_line); - gg_assign(var_decl_nop, build_int_cst_type(INT, 105)); - if( tgt->from()->type != LblLoop ) { perform_outofline( tgt, test_before, N, varys); @@ -8714,10 +9573,6 @@ parser_perform_inline_times(struct cbl_perform_tgt_t *tgt, gg_append_statement( tgt->addresses.testA.label ); gg_append_statement( tgt->addresses.test.label ); - // AT this point, we want to set the line_number to the location of the - // END-PERFORM statement. - gg_set_current_line_number(cobol_location().last_line); - gg_decrement(counter); // Do the test: IF( counter, gt_op, gg_cast(LONG, integer_zero_node) ) @@ -8748,8 +9603,6 @@ parser_perform_inline_times(struct cbl_perform_tgt_t *tgt, SHOW_PARSE_END } - int stash = gg_get_current_line_number(); - gg_set_current_line_number(tgt->addresses.line_number_of_setup_code); gg_append_statement( tgt->addresses.setup.label ); // Get the count: @@ -8780,8 +9633,6 @@ parser_perform_inline_times(struct cbl_perform_tgt_t *tgt, gg_append_statement( tgt->addresses.exit.go_to ); ENDIF - gg_set_current_line_number(stash); - SHOW_PARSE { SHOW_PARSE_INDENT @@ -8792,7 +9643,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; @@ -8837,12 +9688,24 @@ parser_set_conditional88( struct cbl_refer_t refer, bool which_way ) if( !figconst ) { // We are dealing with an ordinary string. - static size_t buffer_size = 0; - static char *buffer = NULL; - size_t length = src->first.size(); - raw_to_internal(&buffer, &buffer_size, src->first.name(), length); + + // When Jim gets around to converting the domain to the target encoding, + // this code will have to be removed +#if 1 + char *fname = xstrdup(src->first.name()); + charmap_t *charmap = __gg__get_charmap(tgt->codeset.encoding); + for(size_t i=0; i<strlen(fname); i++) + { + fname[i] = charmap->mapped_character(fname[i]); + } + move_tree_to_field( parent, + build_string_literal(strlen(fname)+1, fname)); + free(fname); +#else move_tree_to_field( parent, - gg_string_literal(buffer)); + build_string_literal(src->first.size()+1, + src->first.name())); +#endif } else { @@ -8859,6 +9722,10 @@ static void set_user_status(struct cbl_file_t *file) { // This routine sets the user_status, if any, to the cblc_file_t::status + + // We have to do it this way, because in the case where the file->user_status + // is in linkage, the memory addresses can end up pointing to the wrong + // places if(file->user_status) { cbl_field_t *user_status = cbl_field_of(symbol_at(file->user_status)); @@ -8900,7 +9767,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); } @@ -8966,8 +9833,8 @@ parser_file_add(struct cbl_file_t *file) gg_assign(array_of_keys, gg_cast(build_pointer_type(cblc_field_p_type_node), gg_malloc(build_int_cst_type(SIZE_T, - (number_of_key_fields+1) - *sizeof(void *))))); + (number_of_key_fields+1) + *int_size_in_bytes(VOID_P))))); strcpy(achName, "_"); strcat(achName, file->name); @@ -8978,8 +9845,8 @@ parser_file_add(struct cbl_file_t *file) gg_assign(key_numbers, gg_cast(build_pointer_type(INT), gg_malloc(build_int_cst_type(SIZE_T, - (number_of_key_fields+1) - *sizeof(int))))); + (number_of_key_fields+1) + *int_size_in_bytes(INT))))); strcpy(achName, "_"); strcat(achName, file->name); @@ -8991,7 +9858,7 @@ parser_file_add(struct cbl_file_t *file) gg_cast(build_pointer_type(INT), gg_malloc(build_int_cst_type(SIZE_T, (number_of_key_fields+1) - *sizeof(int))))); + *int_size_in_bytes(INT))))); size_t index = 0; for( size_t i=0; i<file->nkey; i++ ) @@ -9025,17 +9892,21 @@ 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__); } +#pragma message "Verify program-id is disambiguated" + size_t symbol_table_index = symbol_unique_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, @@ -9052,12 +9923,15 @@ parser_file_add(struct cbl_file_t *file) build_int_cst_type(INT, (int)file->optional), build_int_cst_type(SIZE_T, varies.min), build_int_cst_type(SIZE_T, varies.max), +/* Right now, file->codeset.encoding is not being set properly. Remove this + comment and fix the following code when that's repaired. */ +// build_int_cst_type(INT, (int)file->codeset.encoding), + build_int_cst_type(INT, current_encoding(display_encoding_e)), + build_int_cst_type(INT, (int)file->codeset.alphabet), NULL_TREE); 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 ) { @@ -9068,6 +9942,44 @@ parser_file_open( size_t nfiles, struct cbl_file_t *files[], int mode_char ) } } +static +tree get_the_filename(bool "ed_name, const cbl_file_t *file) + { + // The cbl_file_t has a cbl_field_t *filename. This can be a FldAlphanumeric. + // The runtime has a (char *)filename, so we need to + // do a runtime conversion. + + tree psz; // This is going to be either the name of the file, or the + // possible run-time environment variable that will contain + // the name of the file. + + cbl_field_t *field_of_name = symbol_field_forward(file->filename); + quoted_name = false; + if( field_of_name->type == FldForward ) + { + // The target of ASSIGN TO was unquoted, but didn't resolve to a + // cbl_field_t. This means that the name of the field is an + // environment variable that will hold the file name + psz = gg_define_char_star(); + gg_assign(psz, gg_strdup(gg_string_literal(field_of_name->name))); + } + else + { + // The name is coming from a presumably FldAlphaNumeric variable + psz = get_string_from(field_of_name); + gg_call( CHAR_P, + "__gg__convert_encoding", + psz, + build_int_cst_type(INT, + field_of_name->codeset.encoding), + build_int_cst_type(INT, + DEFAULT_SOURCE_ENCODING), + NULL_TREE); + quoted_name = true; + } + return psz; + } + void parser_file_open( struct cbl_file_t *file, int mode_char ) { @@ -9098,12 +10010,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) ) @@ -9119,36 +10032,15 @@ parser_file_open( struct cbl_file_t *file, int mode_char ) TRACE1_END } - // The cbl_file_t has a cbl_field_t *filename. This can be a FldAlphanumeric. - // The runtime has a (char *)filename, so we need to - // do a runtime conversion. - - tree psz; // This is going to be either the name of the file, or the - // possible run-time environment variable that will contain - // the name of the file. - - cbl_field_t *field_of_name = symbol_field_forward(file->filename); - bool quoted_name = false; - if( field_of_name->type == FldForward ) - { - // The target of ASSIGN TO was unquoted, but didn't resolve to a - // cbl_field_t. This means that the name of the field is an - // environment variable that will hold the file name - psz = gg_define_char_star(); - gg_assign(psz, gg_strdup(gg_string_literal(field_of_name->name))); - } - else - { - // The name is coming from a presumably FldAlphaNumeric variable - psz = get_string_from(field_of_name); - quoted_name = true; - } + bool quoted_name; + tree pszFilename = get_the_filename(quoted_name, file); + sv_is_i_o = true; store_location_stuff("OPEN"); gg_call(VOID, "__gg__file_open", gg_get_address_of(file->var_decl_node), - psz, + pszFilename, build_int_cst_type(INT, mode_char), quoted_name ? integer_one_node : integer_zero_node, NULL_TREE); @@ -9176,12 +10068,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 @@ -9195,6 +10088,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", @@ -9244,27 +10138,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); @@ -9273,13 +10169,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", @@ -9360,23 +10257,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); } @@ -9388,7 +10285,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 @@ -9414,6 +10311,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", @@ -9457,13 +10355,19 @@ void parser_file_delete( struct cbl_file_t *file, bool /*sequentially*/ ) { Analyze(); + + if( !file ) + { + cbl_internal_error("The file pointer should not be null"); + abort(); // Because cppcheck doesn't recognize [[noerror]] + } + bool sequentially = file->access == file_access_seq_e || file->org == file_sequential_e || file->org == file_line_sequential_e; SHOW_PARSE { SHOW_PARSE_HEADER - if(file) { SHOW_PARSE_TEXT(" "); SHOW_PARSE_TEXT(file->name); @@ -9476,13 +10380,10 @@ parser_file_delete( struct cbl_file_t *file, bool /*sequentially*/ ) SHOW_PARSE_TEXT(" sequentially") } } - else - { - SHOW_PARSE_TEXT(" *file is NULL") - } SHOW_PARSE_END } + sv_is_i_o = true; store_location_stuff("DELETE"); gg_call(VOID, "__gg__file_delete", @@ -9500,6 +10401,121 @@ parser_file_delete( struct cbl_file_t *file, bool /*sequentially*/ ) } } +static void +set_up_delete_file_label(cbl_label_t *delete_file_label) + { + if( delete_file_label ) + { + if( !delete_file_label->structs.delete_file ) + { + delete_file_label->structs.delete_file + = static_cast<cbl_delete_file_t *> + (xmalloc(sizeof(struct cbl_delete_file_t))); + // Set up the address pairs for this clause + gg_create_goto_pair( + &delete_file_label->structs.delete_file->over.go_to, + &delete_file_label->structs.delete_file->over.label); + gg_create_goto_pair( + &delete_file_label->structs.delete_file->exception.go_to, + &delete_file_label->structs.delete_file->exception.label); + gg_create_goto_pair( + &delete_file_label->structs.delete_file->no_exception.go_to, + &delete_file_label->structs.delete_file->no_exception.label); + gg_create_goto_pair( + &delete_file_label->structs.delete_file->bottom.go_to, + &delete_file_label->structs.delete_file->bottom.label); + } + } + } + +void +parser_file_delete_file( cbl_label_t *name, + std::vector<cbl_file_t*> filenames ) + { + // This removes a file from the file system. It is distinct from the + // FILE DELETE statement, which deletes a record from a file. + SHOW_PARSE + { + SHOW_PARSE_HEADER + SHOW_PARSE_TEXT(" "); + SHOW_PARSE_TEXT(name->name); + for(size_t i=0; i<filenames.size(); i++) + { + SHOW_PARSE_INDENT + SHOW_PARSE_TEXT(filenames[i]->name) + } + SHOW_PARSE_END + } + set_up_delete_file_label(name); + tree there_was_an_error = gg_define_int(0); + for(size_t i=0; i<filenames.size(); i++) + { + bool quoted_name; + tree pszFilename = get_the_filename(quoted_name, filenames[i]); + gg_assign(there_was_an_error, + gg_bitwise_or(there_was_an_error, + gg_call_expr( + INT, + "__gg__file_remove", + gg_get_address_of(filenames[i]->var_decl_node), + pszFilename, + quoted_name ? integer_one_node : integer_zero_node, + NULL_TREE))); + set_user_status(filenames[i]); + } + IF( there_was_an_error, eq_op, integer_zero_node ) + { + // There was no error detected. + gg_append_statement(name->structs.delete_file->no_exception.go_to); + } + ELSE + { + // There was an error detected. + gg_append_statement(name->structs.delete_file->exception.go_to); + } + } + +void +parser_file_delete_on_exception( cbl_label_t *name ) + { + SHOW_PARSE + { + SHOW_PARSE_HEADER + SHOW_PARSE_TEXT(" "); + SHOW_PARSE_TEXT(name->name); + SHOW_PARSE_END + } + gg_append_statement(name->structs.delete_file->bottom.go_to); + gg_append_statement(name->structs.delete_file->exception.label); + } + +void +parser_file_delete_not_exception( cbl_label_t *name ) + { + SHOW_PARSE + { + SHOW_PARSE_HEADER + SHOW_PARSE_TEXT(" "); + SHOW_PARSE_TEXT(name->name); + SHOW_PARSE_END + } + gg_append_statement(name->structs.delete_file->bottom.go_to); + gg_append_statement(name->structs.delete_file->no_exception.label); + } + +void +parser_file_delete_end( cbl_label_t *name ) + { + SHOW_PARSE + { + SHOW_PARSE_HEADER + SHOW_PARSE_TEXT(" "); + SHOW_PARSE_TEXT(name->name); + SHOW_PARSE_END + } + gg_append_statement(name->structs.delete_file->bottom.label); + } + void parser_file_rewrite(cbl_file_t *file, cbl_field_t *record_area, @@ -9539,6 +10555,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", @@ -9634,8 +10651,8 @@ parser_file_start(struct cbl_file_t *file, // A key has a number of fields for(size_t ifield=0; ifield<file->keys[key_number].nfield; ifield++) { - size_t field_index = file->keys[key_number].fields[ifield]; - cbl_field_t *field = cbl_field_of(symbol_at(field_index)); + size_t nfield = file->keys[key_number].fields[ifield]; + cbl_field_t *field = cbl_field_of(symbol_at(nfield)); combined_length += field->data.capacity; } gg_assign(length, build_int_cst_type(SIZE_T, combined_length)); @@ -9645,9 +10662,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", @@ -9661,15 +10679,53 @@ parser_file_start(struct cbl_file_t *file, static void inspect_tally(bool backward, - cbl_refer_t identifier_1, - unsigned long n_identifier_2, - cbx_inspect_t<cbl_refer_t>* identifier_2) + const cbl_refer_t &identifier_1, + cbl_inspect_opers_t& identifier_2) { Analyze(); // This is an INSPECT FORMAT 1 SHOW_PARSE { SHOW_PARSE_HEADER + char ach[128]; + sprintf(ach, "There are %lu identifier_2", gb4(identifier_2.size())); + SHOW_PARSE_TEXT(ach); + for(size_t i=0; i<identifier_2.size(); i++) + { + SHOW_PARSE_INDENT + sprintf(ach, "%lu: bounds: %lu", gb4(i), gb4(identifier_2[i].nbound())); + SHOW_PARSE_TEXT(ach); + for(size_t j=0; j<identifier_2[i].nbound(); j++) + { + SHOW_PARSE_INDENT + sprintf(ach, " %lu: matches: %lu", + gb4(j), gb4(identifier_2[i][j].matches.size())); + SHOW_PARSE_TEXT(ach); + + SHOW_PARSE_INDENT + if( identifier_2[i][j].bound == bound_characters_e ) + { + SHOW_PARSE_TEXT(" bound_characters"); + } + else + { + SHOW_PARSE_TEXT(" bound_leading/all"); + } + + if( identifier_2[i][j].matches.size() ) + { + SHOW_PARSE_INDENT + sprintf(ach, " before %p", + as_voidp(identifier_2.at(i).at(j).matches.at(0).before.identifier_4.field)); + SHOW_PARSE_TEXT(ach); + SHOW_PARSE_INDENT + sprintf(ach, " after %p", + as_voidp(identifier_2.at(i).at(j).matches.at(0).after.identifier_4.field)); + SHOW_PARSE_TEXT(ach); + } + } + } + SHOW_PARSE_END } @@ -9679,6 +10735,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++; @@ -9692,12 +10749,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: @@ -9708,7 +10764,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++; @@ -9735,15 +10791,17 @@ inspect_tally(bool backward, gg_assign(int_size, build_int_cst_type(INT, n_integers)); gg_assign(integers, gg_cast(SIZE_T_P, - gg_realloc(integers, n_integers * sizeof(void *)))); + gg_realloc(integers, + n_integers + * int_size_in_bytes(VOID_P)))); } ELSE { } 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; @@ -9762,34 +10820,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; } } } @@ -9801,7 +10867,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, @@ -9809,16 +10875,12 @@ inspect_tally(bool backward, backward ? integer_one_node : integer_zero_node, integers, NULL_TREE); - - // And free up the memory we allocated - free(pcbl_refers); } static void inspect_replacing(int backward, - cbl_refer_t identifier_1, - unsigned long n_ops, - cbx_inspect_t<cbl_refer_t>* operations) + const cbl_refer_t &identifier_1, + cbl_inspect_opers_t &operations) { Analyze(); // This is an INSPECT FORMAT 2 @@ -9829,6 +10891,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; @@ -9839,9 +10902,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 @@ -9860,13 +10923,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(); } } @@ -9874,8 +10937,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); @@ -9886,19 +10949,21 @@ inspect_replacing(int backward, gg_assign(int_size, build_int_cst_type(INT, n_integers)); gg_assign(integers, gg_cast(SIZE_T_P, - gg_realloc(integers, n_integers * sizeof(void *)))); + gg_realloc(integers, + n_integers + * int_size_in_bytes(VOID_P)))); } ELSE { } 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; @@ -9906,28 +10971,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 { @@ -9935,14 +11000,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 } @@ -9951,19 +11016,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 { @@ -9971,15 +11036,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 } @@ -9987,9 +11052,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. @@ -10004,7 +11069,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, @@ -10015,13 +11080,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 @@ -10031,12 +11095,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); } } @@ -10060,27 +11124,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 ); @@ -10130,10 +11194,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 ); @@ -10144,10 +11208,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 ); @@ -10156,7 +11220,7 @@ parser_intrinsic_numval_c( cbl_field_t *f, void parser_intrinsic_subst( cbl_field_t *f, - cbl_refer_t& ref1, + const cbl_refer_t& ref1, size_t argc, cbl_substitute_t * argv ) { @@ -10164,6 +11228,13 @@ parser_intrinsic_subst( cbl_field_t *f, SHOW_PARSE { SHOW_PARSE_HEADER + SHOW_PARSE_FIELD(" TO ", f) + for(size_t i=0; i<argc; i++) + { + SHOW_PARSE_INDENT + SHOW_PARSE_FIELD(" ", argv[i].orig.field) + SHOW_PARSE_FIELD(" ", argv[i].replacement.field) + } SHOW_PARSE_END } TRACE1 @@ -10172,10 +11243,13 @@ parser_intrinsic_subst( cbl_field_t *f, TRACE1_END } + sv_is_i_o = true; store_location_stuff("SUBSTITUTE"); - unsigned char *control_bytes = (unsigned char *)xmalloc(argc * sizeof(unsigned char)); - cbl_refer_t *arg1 = (cbl_refer_t *)xmalloc(argc * sizeof(cbl_refer_t)); - cbl_refer_t *arg2 = (cbl_refer_t *)xmalloc(argc * sizeof(cbl_refer_t)); + unsigned char *control_bytes = + static_cast<unsigned char *>(xmalloc(argc * sizeof(unsigned char))); + gcc_assert(control_bytes); + std::vector<cbl_refer_t> arg1(argc); + std::vector<cbl_refer_t> arg2(argc); for(size_t i=0; i<argc; i++) { @@ -10191,14 +11265,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, @@ -10206,8 +11280,6 @@ parser_intrinsic_subst( cbl_field_t *f, gg_free(control); - free(arg2); - free(arg1); free(control_bytes); } @@ -10231,7 +11303,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 } @@ -10300,7 +11373,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, @@ -10355,15 +11430,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), @@ -10404,6 +11479,16 @@ parser_intrinsic_call_1( cbl_field_t *tgt, } } } + else if( strcmp(function_name, "__gg__char") == 0 ) + { + gg_call(VOID, + function_name, + gg_get_address_of(tgt->var_decl_node), + gg_get_address_of(ref1.field->var_decl_node), + refer_offset(ref1), + refer_size_source(ref1), + NULL_TREE); + } else { TRACE1 @@ -10419,7 +11504,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); } @@ -10458,14 +11543,16 @@ parser_intrinsic_call_2( cbl_field_t *tgt, TRACE1_REFER("parameter 2: ", ref2, "") } store_location_stuff(function_name); + gg_call(VOID, 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), + ref2.field ? gg_get_address_of(ref2.field->var_decl_node) + : null_pointer_node, + refer_offset(ref2), refer_size_source(ref2), NULL_TREE); TRACE1 @@ -10512,13 +11599,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 @@ -10567,16 +11654,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 @@ -10609,7 +11696,9 @@ static void create_lsearch_address_pairs(struct cbl_label_t *name) { // Create the lsearch structure - name->structs.lsearch = (cbl_lsearch_t *)xmalloc(sizeof(cbl_lsearch_t)); + name->structs.lsearch = + static_cast<cbl_lsearch_t *>(xmalloc(sizeof(cbl_lsearch_t))); + gcc_assert(name->structs.lsearch); cbl_lsearch_t *lsearch = name->structs.lsearch; gg_create_goto_pair(&lsearch->addresses.at_exit.go_to, @@ -10673,7 +11762,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); @@ -10859,7 +11948,9 @@ parser_bsearch_start( cbl_label_t* name, } // We need a cbl_bsearch_t structure: - name->structs.bsearch = (cbl_bsearch_t *)xmalloc(sizeof(cbl_bsearch_t)); + name->structs.bsearch = + static_cast<cbl_bsearch_t *>(xmalloc(sizeof(cbl_bsearch_t))); + gcc_assert(name->structs.bsearch); cbl_bsearch_t *bsearch = name->structs.bsearch; // Create the address/label pairs we need @@ -10892,6 +11983,8 @@ parser_bsearch_start( cbl_label_t* name, current = parent_of(current); } + CHECK_FIELD(current); + // There are a number of things we learn from the field "current" // We get the index: @@ -10910,7 +12003,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(); @@ -10999,12 +12092,11 @@ parser_bsearch_conditional( cbl_label_t* name ) } bool -is_ascending_key(cbl_refer_t key) +is_ascending_key(const cbl_refer_t& key) { bool retval = true; cbl_field_t *family_tree = key.field; - gcc_assert(family_tree); while( family_tree ) { if( family_tree->occurs.nkey ) @@ -11013,14 +12105,17 @@ is_ascending_key(cbl_refer_t key) } family_tree = parent_of(family_tree); } + + CHECK_FIELD(family_tree); gcc_assert(family_tree->occurs.nkey); + for(size_t i=0; i<family_tree->occurs.nkey; i++) { for(size_t j=0; j<family_tree->occurs.keys[i].field_list.nfield; j++) { size_t index_of_field = family_tree->occurs.keys[i].field_list.fields[j]; - cbl_field_t *key_field = cbl_field_of(symbol_at(index_of_field)); + const cbl_field_t *key_field = cbl_field_of(symbol_at(index_of_field)); if( strcmp( key_field->name, key.field->name ) == 0 ) @@ -11116,7 +12211,9 @@ gg_array_of_field_pointers( size_t N, cbl_field_t **fields ) { tree retval = gg_define_variable(build_pointer_type(cblc_field_p_type_node)); - gg_assign(retval, gg_cast(build_pointer_type(cblc_field_p_type_node), gg_malloc( build_int_cst_type(SIZE_T, N * sizeof(void *))))); + gg_assign(retval, gg_cast(build_pointer_type(cblc_field_p_type_node), + gg_malloc(build_int_cst_type(SIZE_T, + N * int_size_in_bytes(VOID_P))))); for(size_t i=0; i<N; i++) { gg_assign(gg_array_value(retval, i), gg_get_address_of(fields[i]->var_decl_node)); @@ -11144,8 +12241,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 @@ -11163,22 +12259,26 @@ parser_sort(cbl_refer_t tableref, gcc_assert(table->var_decl_node); if( !is_table(table) ) { - cbl_internal_error( "%s(): asked to sort %s, but it's not a table", + cbl_internal_error( "%s: asked to sort %s, which is not a table", __func__, tableref.field->name); } - size_t total_keys = 0; - for( size_t i=0; i<nkeys; i++ ) - { - total_keys += keys[i].nfield; - } - cbl_field_t **flattened_fields = (cbl_field_t **)xmalloc(total_keys * sizeof(cbl_field_t *)); - size_t *flattened_ascending = (size_t *)xmalloc(total_keys * sizeof(size_t)); + size_t total_keys = std::accumulate( keys.begin(), keys.end(), 0, + [](size_t n, const cbl_key_t& key ) { + return n + key.fields.size(); + } ); + typedef const cbl_field_t * const_field_t; + const_field_t *flattened_fields = + static_cast<const_field_t *>(xmalloc(total_keys * sizeof(cbl_field_t *))); + gcc_assert(flattened_fields); + size_t *flattened_ascending = + static_cast<size_t *>(xmalloc(total_keys * sizeof(size_t))); + gcc_assert(flattened_ascending); size_t key_index = 0; - for( size_t i=0; i<nkeys; i++ ) + for( size_t i=0; i<keys.size(); i++ ) { - for( size_t j=0; j<keys[i].nfield; j++ ) + for( size_t j=0; j<keys[i].fields.size(); j++ ) { flattened_fields[key_index] = keys[i].fields[j]; flattened_ascending[key_index] = keys[i].ascending ? 1 : 0; @@ -11187,13 +12287,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 ) { @@ -11203,7 +12304,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, @@ -11226,8 +12327,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, @@ -11291,7 +12391,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__); } @@ -11304,18 +12404,22 @@ parser_file_sort( cbl_file_t *workfile, // clone of the code for handling multiple keys, each of which can have // multiple fields. - size_t total_keys = 0; - for( size_t i=0; i<nkeys; i++ ) - { - total_keys += keys[i].nfield; - } - cbl_field_t **flattened_fields = (cbl_field_t **)xmalloc(total_keys * sizeof(cbl_field_t *)); - size_t *flattened_ascending = (size_t *) xmalloc(total_keys * sizeof(size_t)); + size_t total_keys = std::accumulate( keys.begin(), keys.end(), 0, + []( size_t n, const cbl_key_t& key ) { + return n + key.fields.size(); + } ); + typedef const cbl_field_t * const_field_t; + auto flattened_fields + = static_cast<const_field_t *>(xmalloc(total_keys * sizeof(cbl_field_t *))); + gcc_assert(flattened_fields); + size_t *flattened_ascending = + static_cast<size_t *>(xmalloc(total_keys * sizeof(size_t))); + gcc_assert(flattened_ascending); size_t key_index = 0; - for( size_t i=0; i<nkeys; i++ ) + for( size_t i=0; i<keys.size(); i++ ) { - for( size_t j=0; j<keys[i].nfield; j++ ) + for( size_t j=0; j<keys[i].fields.size(); j++ ) { flattened_fields[key_index] = keys[i].fields[j]; flattened_ascending[key_index] = keys[i].ascending ? 1 : 0; @@ -11324,7 +12428,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 ); @@ -11420,7 +12525,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__); } } @@ -11468,7 +12573,9 @@ parser_return_start( cbl_file_t *workfile, cbl_refer_t into ) // We assume that workfile is open. - workfile->addresses = (cbl_sortreturn_t *)xmalloc(sizeof(cbl_sortreturn_t)); + workfile->addresses = static_cast<cbl_sortreturn_t *> + (xmalloc(sizeof(cbl_sortreturn_t))); + gcc_assert(workfile->addresses); gg_create_goto_pair(&workfile->addresses->at_end.go_to, &workfile->addresses->at_end.label); gg_create_goto_pair(&workfile->addresses->not_at_end.go_to, @@ -11499,7 +12606,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 @@ -11608,7 +12721,8 @@ gg_array_of_file_pointers( size_t N, { tree retval = gg_define_variable(build_pointer_type(cblc_file_p_type_node)); gg_assign(retval, gg_cast( build_pointer_type(cblc_file_p_type_node), - gg_malloc( build_int_cst_type(SIZE_T, N * sizeof(void *))))); + gg_malloc( build_int_cst_type(SIZE_T, + N * int_size_in_bytes(VOID_P))))); for(size_t i=0; i<N; i++) { gg_assign(gg_array_value(retval, i), gg_get_address_of(files[i]->var_decl_node)); @@ -11619,8 +12733,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, @@ -11643,20 +12756,23 @@ parser_file_merge( cbl_file_t *workfile, build_int_cst_type(INT, file_sequential_e)); } - size_t total_keys = 0; - for( size_t i=0; i<nkeys; i++ ) - { - total_keys += keys[i].nfield; - } - cbl_field_t **flattened_fields - = (cbl_field_t **)xmalloc(total_keys * sizeof(cbl_field_t *)); + size_t total_keys = std::accumulate( keys.begin(), keys.end(), 0, + []( size_t i, const cbl_key_t& key ) { + return i + key.fields.size(); + } ); + typedef const cbl_field_t * const_field_t; + const_field_t *flattened_fields + = static_cast<const_field_t *> + (xmalloc(total_keys * sizeof(cbl_field_t *))); + gcc_assert(flattened_fields); size_t *flattened_ascending - = (size_t *)xmalloc(total_keys * sizeof(size_t)); + = static_cast<size_t *>(xmalloc(total_keys * sizeof(size_t))); + gcc_assert(flattened_ascending); size_t key_index = 0; - for( size_t i=0; i<nkeys; i++ ) + for( size_t i=0; i<keys.size(); i++ ) { - for( size_t j=0; j<keys[i].nfield; j++ ) + for( size_t j=0; j<keys[i].fields.size(); j++ ) { flattened_fields[key_index] = keys[i].fields[j]; flattened_ascending[key_index] = keys[i].ascending ? 1 : 0; @@ -11665,7 +12781,9 @@ parser_file_merge( cbl_file_t *workfile, } // Create the array of cbl_field_t pointers for the keys - tree all_keys = gg_array_of_field_pointers(total_keys, flattened_fields); + tree all_keys = gg_array_of_field_pointers( + total_keys, + const_cast<cbl_field_t**>(flattened_fields)); // Create the array of integers that are the flags for ASCENDING: tree ascending = gg_array_of_size_t(total_keys, flattened_ascending); @@ -11689,6 +12807,9 @@ parser_file_merge( cbl_file_t *workfile, ELSE ENDIF + const cbl_enabled_exceptions_t& + enabled_exceptions( cdf_enabled_exceptions() ); + for(size_t i=0; i<ninputs; i++) { if( process_this_exception(ec_sort_merge_file_open_e) ) @@ -11732,7 +12853,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), @@ -11826,7 +12947,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__); } } @@ -11846,7 +12967,8 @@ parser_string_overflow( cbl_label_t *name ) */ name->structs.unstring - = (cbl_unstring_t *)xmalloc(sizeof(struct cbl_unstring_t) ); + = static_cast<cbl_unstring_t *>(xmalloc(sizeof(struct cbl_unstring_t))); + gcc_assert(name->structs.unstring); // Set up the address pairs for this clause gg_create_goto_pair(&name->structs.unstring->over.go_to, @@ -11904,9 +13026,9 @@ parser_unstring(cbl_refer_t src, gg_append_statement(not_overflow->structs.unstring->over.label); } - cbl_refer_t *delims = (cbl_refer_t *)xmalloc(ndelimited * sizeof(cbl_refer_t)); - char *alls = (char *)xmalloc(ndelimited+1); - + std::vector<cbl_refer_t> delims(ndelimited); + char *alls = static_cast<char *>(xmalloc(ndelimited+1)); + gcc_assert(alls); for(size_t i=0; i<ndelimited; i++) { delims[i] = delimiteds[i]; @@ -11916,7 +13038,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); @@ -11926,21 +13048,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 ) { @@ -11976,12 +13097,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 { @@ -11998,7 +13119,8 @@ parser_string( cbl_refer_t tgt, } // We need an array of nsource+1 integers: - size_t *integers = (size_t *)xmalloc((nsource+1)*sizeof(size_t)); + size_t *integers = static_cast<size_t *>(xmalloc((nsource+1)*sizeof(size_t))); + gcc_assert(integers); // Count up how many treeplets we are going to need: size_t cblc_count = 2; // tgt and pointer @@ -12007,7 +13129,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; @@ -12032,7 +13154,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, @@ -12042,7 +13164,6 @@ parser_string( cbl_refer_t tgt, gg_free(pintegers); free(integers); - free(refers); if( overflow ) { @@ -12090,8 +13211,9 @@ parser_call_exception( cbl_label_t *name ) } name->structs.call_exception - = (cbl_call_exception_t *)xmalloc(sizeof(struct cbl_call_exception_t) ); - + = static_cast<cbl_call_exception_t *> + (xmalloc(sizeof(struct cbl_call_exception_t))); + gcc_assert(name->structs.call_exception); // Set up the address pairs for this clause gg_create_goto_pair(&name->structs.call_exception->over.go_to, &name->structs.call_exception->over.label); @@ -12139,11 +13261,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; @@ -12151,8 +13273,10 @@ create_and_call(size_t narg, if(narg) { - arguments = (tree *)xmalloc(2*narg * sizeof(tree)); - allocated = (int * )xmalloc(narg * sizeof(int)); + arguments = static_cast<tree *>(xmalloc(2*narg * sizeof(tree))); + gcc_assert(arguments); + allocated = static_cast<int *>(xmalloc(narg * sizeof(int))); + gcc_assert(allocated); } // Put the arguments onto the "stack" of calling parameters: @@ -12202,7 +13326,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)); } @@ -12331,7 +13455,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))); } @@ -12344,7 +13468,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))); } @@ -12364,28 +13488,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( gg_token_location(), + returned_value_type, + address_of_function, narg, - arguments ); + arguments); + // Among other possibilities, this might be a forward reference to a + // contained function. The name here is "prog2", and ultimately will need + // to be replaced with a call to "prog2.62". So, this call expr goes into + // a list of call expressions whose function_decl targets will be replaced. + parser_call_target( funcname, call_expr ); + } + tree returned_value; + if( returned.field ) { - returned_value = gg_define_variable(returned_value_type); + // Because the CALL had a RETURNING clause, RETURN-CODE doesn't return a + // value. So, we make sure it is zero + //// gg_assign(var_decl_return_code, build_int_cst_type(SHORT, 0)); + + // We expect the return value to be a 64-bit or 128-bit integer. How + // we treat that returned value depends on the target. - // We are expecting a return value of type CHAR_P, SSIZE_T, SIZE_T, - // UINT128 or INT128 + // Pick up that value: + returned_value = gg_define_variable(returned_value_type); push_program_state(); gg_assign(returned_value, gg_cast(returned_value_type, call_expr)); pop_program_state(); - // Because the CALL had a RETURNING clause, RETURN-CODE doesn't return a - // value. So, we make sure it is zero - gg_assign(var_decl_return_code, build_int_cst_type(SHORT, 0)); - if( returned_value_type == CHAR_P ) { tree returned_location = gg_define_uchar_star(); @@ -12393,9 +13556,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: @@ -12405,15 +13568,17 @@ create_and_call(size_t narg, { // Somebody was discourteous enough to return a NULL pointer // We'll jam in spaces: + charmap_t *charmap = __gg__get_charmap(returned.field->codeset.encoding); + int dest_space = charmap->mapped_character(ascii_space); gg_memset( returned_location, - char_nodes[(unsigned char)internal_space], + char_nodes[(unsigned char)dest_space], returned_length ); } ELSE { // There is a valid pointer. Do the assignment. move_tree(returned.field, - refer_offset_dest(returned), + refer_offset(returned), returned_value, integer_one_node); } @@ -12433,13 +13598,14 @@ create_and_call(size_t narg, // We got back a 64-bit or 128-bit integer. The called and calling // programs have to agree on size, but other than that, integer numeric // types are converted one to the other. + 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), - member(returned.field->var_decl_node, "rdigits"), + gg_cast(INT, member(returned.field->var_decl_node, "rdigits")), build_int_cst_type(INT, truncation_e), null_pointer_node, NULL_TREE ); @@ -12458,7 +13624,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)); @@ -12478,34 +13644,17 @@ 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: + // Because no explicit returning value is expected, we just call it. We + // expect COBOL routines to set RETURN-CODE when they think it necessary. push_program_state(); - gg_assign(returned_value, gg_cast(SHORT, call_expr)); - // And after the call, we restore it: + gg_append_statement(call_expr); 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 - } } for( size_t i=0; i<narg; i++ ) @@ -12552,7 +13701,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(" )") @@ -12613,39 +13762,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.original(), + 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, + function_pointer, + nullptr, returned_value_type, returned, - not_except - ); + not_except); } ELSE { @@ -12672,7 +13831,8 @@ parser_call( cbl_refer_t name, NULL_TREE); gg_printf("WARNING: %s:%d \"CALL %s\" not found" - " with no \"CALL ON EXCEPTION\" phrase\n", + " with no \"CALL ON EXCEPTION\" phrase.\n" + "(You might need -rdynamic or --export-dynamic for symbols in the executable.)\n", gg_string_literal(current_filename.back().c_str()), build_int_cst_type(INT, CURRENT_LINE_NUMBER), mangled_name, @@ -12693,8 +13853,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. @@ -12704,10 +13862,80 @@ parser_entry_activate( size_t iprog, const cbl_label_t *declarative ) assert(iprog == symbol_elem_of(declarative)->program); } -// Define ENTRY point with alternative LINKAGE +static tree entry_goto; +static tree entry_label; +static tree entry_addr; + void -parser_entry( cbl_field_t */*name*/, size_t /*narg*/, cbl_ffi_arg_t */*args*/ ) +parser_entry( const cbl_field_t *name, size_t nusing, cbl_ffi_arg_t *args ) { + // We are implementing the ENTRY statement, which creates an alternative + // entry point into the current program-id. There is no actual way to do + // that literally. So, we are going to create a separate routine that sets + // things up and then calls the current routine with the information it needs + // to transfer processing to the ENTRY point. + + SHOW_PARSE + { + SHOW_PARSE_HEADER + SHOW_PARSE_TEXT(" ") + SHOW_PARSE_TEXT(name->data.original()) + SHOW_PARSE_END + } + + // Get the name of the program that contains the ENTRY statement. + char *name_of_parent = xstrdup(current_function->our_name); + + // Get the name of the ENTRY point. + // cppcheck-suppress nullPointerRedundantCheck + char *psz = cobol_name_mangler(name->data.original()); + + // Create a goto/label pair. The label will be set up here; the goto will + // be used when we re-enter the containing function: + + gg_create_goto_pair(&entry_goto, + &entry_label, + &entry_addr); + + // Start creating the ENTRY function. + tree function_decl = gg_define_function( VOID, + psz, + psz, + NULL_TREE); + free(psz); + + // Modify the default settings for this entry point + 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; + + // When the ENTRY function point is called, we process its "using" + // parameters: + establish_using(nusing, args); + + // Put the entry_label into the global variable that will be picked up + // when the containing program-id is re-entered: + gg_assign(var_decl_entry_label, entry_addr); + + // Get the function address of the containing function. + tree gfa = gg_get_function_address(VOID, name_of_parent); + free(name_of_parent); + + // Call the containing function + gg_append_statement(gg_call_expr_list(VOID, + gfa, + 0, + NULL)); + // We are done with the ENTRY function: + gg_finalize_function(); + + // Lay down the address of the label that matches var_decl_entry_label; + // the containing program-id will jump to this point. + gg_append_statement(entry_label); } void @@ -12728,7 +13956,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 @@ -12737,7 +13965,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)); @@ -12774,7 +14002,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(); @@ -12812,7 +14040,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 @@ -12821,7 +14049,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)); @@ -12835,7 +14063,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(); @@ -12890,11 +14118,11 @@ 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), - build_int_cst_type(SIZE_T, sizeof(void *))); + gg_memcpy(qualified_data_location(tgts[i]), + gg_get_address_of(function_pointer), + sizeof_pointer); } else { @@ -12912,10 +14140,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 ); @@ -12942,7 +14170,8 @@ typedef struct hier_node hier_node() : our_index(0), common(false), - parent_node(NULL) + parent_node(nullptr), + name(nullptr) {} } hier_node; @@ -12986,14 +14215,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 { @@ -13004,7 +14233,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 ) { @@ -13016,11 +14245,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); } } @@ -13059,9 +14288,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; @@ -13073,7 +14302,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); @@ -13105,9 +14334,9 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) // are also accessible by us. Go find them. std::vector<const hier_node *>uncles; find_uncles(nodes[i], uncles); - for( size_t i=0; i<uncles.size(); i++ ) + for( size_t j=0; j<uncles.size(); j++ ) { - const hier_node *uncle = uncles[i]; + const hier_node *uncle = uncles[j]; if( map_of_sets[caller].find(uncle->name) == map_of_sets[caller].end() ) { // We have a COMMON uncle or sibling we haven't seen before. @@ -13145,16 +14374,17 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ) if( callers.find(caller) == callers.end() ) { // We haven't seen this caller before - callers.insert(caller); - char ach[2*sizeof(cbl_name_t)]; + char ach[3*sizeof(cbl_name_t)]; tree names_table_type = build_array_type_nelts(CHAR_P, mol->second.size()+1); - sprintf(ach, "..our_accessible_functions_%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); @@ -13172,7 +14402,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), @@ -13198,13 +14431,17 @@ 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) ); + + callers.insert(caller); } } } @@ -13213,72 +14450,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(); @@ -13289,7 +14460,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 } @@ -13304,159 +14475,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() { @@ -13485,8 +14503,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 @@ -13494,14 +14511,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 } @@ -13510,22 +14519,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 @@ -13548,9 +14547,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( cdf_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 @@ -13570,6 +14596,7 @@ void parser_exception_file( cbl_field_t *tgt, cbl_file_t *file) { Analyze(); + RETURN_IF_PARSE_ONLY; gg_call(VOID, "__gg__func_exception_file", gg_get_address_of(tgt->var_decl_node), @@ -13653,7 +14680,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++) { @@ -13666,12 +14693,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,9 +14708,9 @@ conditional_abs(tree source, cbl_field_t *field) } static bool -mh_identical(cbl_refer_t &destref, - cbl_refer_t &sourceref, - TREEPLET &tsource) +mh_identical(const cbl_refer_t &destref, + const cbl_refer_t &sourceref, + const TREEPLET &tsource) { // Check to see if the two variables are identical types, thus allowing // for a simple byte-for-byte copy of the data areas: @@ -13694,6 +14721,7 @@ mh_identical(cbl_refer_t &destref, && destref.field->data.rdigits == sourceref.field->data.rdigits && (destref.field->attr & (signable_e|separate_e|leading_e)) == (sourceref.field->attr & (signable_e|separate_e|leading_e)) + && destref.field->codeset.encoding == sourceref.field->codeset.encoding && !destref.field->occurs.depending_on && !sourceref.field->occurs.depending_on && !destref.refmod.from @@ -13705,7 +14733,7 @@ mh_identical(cbl_refer_t &destref, ) { // The source and destination are identical in type - if( (sourceref.field->attr & intermediate_e) || !symbol_find_odo(sourceref.field) ) + if( !symbol_find_odo(sourceref.field) ) { Analyze(); // Source doesn't have a depending_on clause @@ -13715,7 +14743,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)); @@ -13725,8 +14753,6 @@ mh_identical(cbl_refer_t &destref, return moved; } -#pragma GCC diagnostic push -#pragma GCC diagnostic ignored "-Wpedantic" static bool mh_source_is_literalN(cbl_refer_t &destref, cbl_refer_t &sourceref, @@ -13749,19 +14775,23 @@ mh_source_is_literalN(cbl_refer_t &destref, SHOW_PARSE_TEXT("mh_source_is_literalN: __gg__psz_to_alpha_move") } - static char *buffer = NULL; - static size_t buffer_size = 0; - raw_to_internal(&buffer, - &buffer_size, - sourceref.field->data.initial, - strlen(sourceref.field->data.initial)); + // We need the data sent to __gg__psz_to_alpha_move to be in the + // encoding of the destination + + size_t charsout; + const char *converted = __gg__iconverter( + sourceref.field->codeset.encoding, + destref.field->codeset.encoding, + sourceref.field->data.initial, + strlen(sourceref.field->data.initial), + &charsout); 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)), + gg_string_literal(converted), + build_int_cst_type(SIZE_T, charsout), NULL_TREE); moved = true; break; @@ -13796,13 +14826,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 @@ -13811,7 +14841,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)); } @@ -13820,7 +14850,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; @@ -13866,9 +14896,9 @@ mh_source_is_literalN(cbl_refer_t &destref, Analyzer.Message("Check to see if result fits"); if( destref.field->data.digits ) { - __int128 power_of_ten = get_power_of_ten(destref.field->data.digits); - IF( gg_abs(source), ge_op, build_int_cst_type(calc_type, - power_of_ten) ) + FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten(destref.field->data.digits); + IF( gg_abs(source), ge_op, wide_int_to_tree(calc_type, + power_of_ten) ) { gg_assign(size_error, gg_bitwise_or(size_error, integer_one_node)); } @@ -13881,7 +14911,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; @@ -13910,7 +14940,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), @@ -13938,14 +14968,32 @@ mh_source_is_literalN(cbl_refer_t &destref, SHOW_PARSE_INDENT SHOW_PARSE_TEXT(" FldAlphaEdited") } + + // __gg__string_to_alpha_edited expects the source string to be in + // the same encoding as the target: + size_t len = strlen(sourceref.field->data.initial); + char *src = + static_cast<char *>(xmalloc(len+1)); + memcpy( src, + sourceref.field->data.initial, + strlen(sourceref.field->data.initial)); + size_t charsout; + const char *converted = __gg__iconverter( + sourceref.field->codeset.encoding, + destref.field->codeset.encoding, + src, + len, + &charsout); gg_call(VOID, - "__gg__string_to_alpha_edited_ascii", + "__gg__string_to_alpha_edited", gg_add( member(destref.field->var_decl_node, "data"), - refer_offset_dest(destref) ), - gg_string_literal(sourceref.field->data.initial), - build_int_cst_type(INT, strlen(sourceref.field->data.initial)), + refer_offset(destref) ), + build_int_cst_type(INT, destref.field->codeset.encoding), + gg_string_literal(converted), + build_int_cst_type(INT, len), gg_string_literal(destref.field->data.picture), NULL_TREE); + free(src); moved = true; break; } @@ -13953,7 +15001,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 @@ -13966,26 +15014,20 @@ mh_source_is_literalN(cbl_refer_t &destref, // The following generated code is the exact equivalent // of the C code: // *(float *)dest = (float)data.value - _Float32 src = (_Float32)sourceref.field->data.value_of(); - tree tsrc = build_string_literal(sizeof(src), (char *)&src); - gg_assign(gg_indirect(gg_cast(build_pointer_type(INT), tdest)), - gg_indirect(gg_cast(build_pointer_type(INT), tsrc ))); + gg_assign(gg_indirect(gg_cast(build_pointer_type(FLOAT), tdest)), + fold_convert (FLOAT, sourceref.field->data.value_of())); break; } case 8: { - _Float64 src = (_Float64)sourceref.field->data.value_of(); - tree tsrc = build_string_literal(sizeof(src), (char *)&src); - gg_assign(gg_indirect(gg_cast(build_pointer_type(LONG), tdest)), - gg_indirect(gg_cast(build_pointer_type(LONG), tsrc ))); + gg_assign(gg_indirect(gg_cast(build_pointer_type(DOUBLE), tdest)), + fold_convert (DOUBLE, sourceref.field->data.value_of())); break; } case 16: { - _Float128 src = (_Float128)sourceref.field->data.value_of(); - tree tsrc = build_string_literal(sizeof(src), (char *)&src); - gg_assign(gg_indirect(gg_cast(build_pointer_type(INT128), tdest)), - gg_indirect(gg_cast(build_pointer_type(INT128), tsrc ))); + gg_assign(gg_indirect(gg_cast(build_pointer_type(FLOAT128), tdest)), + sourceref.field->data.value_of()); break; } } @@ -13995,8 +15037,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)); @@ -14005,7 +15047,6 @@ mh_source_is_literalN(cbl_refer_t &destref, } return moved; } -#pragma GCC diagnostic pop static tree float_type_of(int n) @@ -14025,14 +15066,14 @@ tree float_type_of(int n) } static tree -float_type_of(cbl_field_t *field) +float_type_of(const cbl_field_t *field) { gcc_assert(field->type == FldFloat); return float_type_of(field->data.capacity); } static tree -float_type_of(cbl_refer_t *refer) +float_type_of(const cbl_refer_t *refer) { return float_type_of(refer->field); } @@ -14064,7 +15105,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), @@ -14075,7 +15116,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), @@ -14086,7 +15127,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), @@ -14128,9 +15169,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), @@ -14147,7 +15188,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)); @@ -14157,7 +15198,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); @@ -14174,7 +15215,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)); @@ -14184,7 +15225,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); @@ -14199,7 +15240,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)); @@ -14209,7 +15250,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); @@ -14232,8 +15273,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), @@ -14264,8 +15305,11 @@ picky_memset(tree &dest_p, unsigned char value, size_t length) } static void -picky_memcpy(tree &dest_p, tree &source_p, size_t length) +picky_memcpy(tree &dest_p, const tree &source_p, size_t length, tree zero) { + // This is the routine that copies digits for NumericDisplay. In addition + // to just moving digits from source to destination, it has to handle + // clearing up embedded sign information. if( length ) { tree dest_ep = gg_define_variable(TREE_TYPE(dest_p)); @@ -14274,7 +15318,10 @@ picky_memcpy(tree &dest_p, tree &source_p, size_t length) build_int_cst_type(SIZE_T, length))); WHILE( dest_p, lt_op, dest_ep ) { - gg_assign(gg_indirect(dest_p), gg_indirect(source_p)); + gg_assign(gg_indirect(dest_p), + gg_bitwise_or(zero, + gg_bitwise_and(gg_indirect(source_p), + build_int_cst_type(UCHAR, 0x0F)))); gg_increment(dest_p); gg_increment(source_p); } @@ -14283,10 +15330,10 @@ picky_memcpy(tree &dest_p, tree &source_p, size_t length) } static bool -mh_numeric_display( cbl_refer_t &destref, - cbl_refer_t &sourceref, - TREEPLET &tsource, - tree size_error) +mh_numeric_display( const cbl_refer_t &destref, + const cbl_refer_t &sourceref, + const TREEPLET &tsource, + tree size_error) { bool moved = false; @@ -14296,189 +15343,216 @@ mh_numeric_display( cbl_refer_t &destref, && !(sourceref.field->attr & scaled_e) ) { Analyze(); - // I believe that there are 225 pathways through the following code. That's - // because there are five different valid combination of signable_e, + // I believe that there are 450 pathways through the following code. + // That's because there are five different valid combination of signable_e, // separate_e, and leading_e. There are three possibilities for - // sender/receiver rdigits (too many, too few, and just right), and the same - // for ldigits. 5 * 5 * 3 * 3 = 225. + // sender/receiver rdigits (too many, too few, and just right), and the + // same for ldigits. 5 * 5 * 3 * 3 * 2 = 450. // Fasten your seat belts. - // In order to simplify processing of a signable internal sender, we are - // going to pick up the sign byte and temporarily turn off the sign bit in - // the source data. At the end, we will restore that value. This - // reflexively makes me a bit nervous (it isn't, for example, thread-safe), - // but it makes life easier. + // This routine is complicated by the fact that although I had several + // false starts of putting this into libgcobol, I keep coming back to the + // fact that assignment of zoned values is common. And, so, there are all + // kinds of things that are known at compile time that would turn into + // execution-time decisions if I moved them to the library. So, complex + // or not, I am doing all this code here at compile time because it will + // minimize the code at execution time. + + // One thing to keep in mind is the problem caused by a source value being + // internally signed. That turns an ASCII "123" into "12t", and we + // very probably don't want that "t" to find its way into the destination + // value. The internal sign characteristic of ASCII is that the high + // nybble of the sign location is 0x30 or 0x70. For EBCDIC, the high + // nybble is 0xC0 for positive values, and 0xD0 for negative; all other + // digits are 0x70. + + charmap_t *charmap_source = + __gg__get_charmap(sourceref.field->codeset.encoding); + charmap_t *charmap_dest = + __gg__get_charmap( destref.field->codeset.encoding); + + static tree source_sign_loc = gg_define_variable(UCHAR_P, + "..mhnd_sign_loc", + vs_file_static); + static tree dest_sign_loc = gg_define_variable(UCHAR_P, + "..mhnd_dest_sign_loc", + vs_file_static); + static tree source_sign = gg_define_variable(INT, + "..mhnd_sign", + vs_file_static); + // The destination data pointer + static tree dest_p = gg_define_variable( UCHAR_P, + "..mhnd_dest", + vs_file_static); + // The source data pointer + static tree source_p = gg_define_variable( UCHAR_P, + "..mhnd_source", + vs_file_static); + // When we need an end pointer + static tree source_ep = gg_define_variable( UCHAR_P, + "..mhnd_source_e", + vs_file_static); + + bool source_is_signable = sourceref.field->attr & signable_e; + bool source_is_leading = sourceref.field->attr & leading_e; + bool source_is_separate = sourceref.field->attr & separate_e; + + bool dest_is_signable = destref.field->attr & signable_e; + bool dest_is_leading = destref.field->attr & leading_e; + bool dest_is_separate = destref.field->attr & separate_e; + + int switch_source = (source_is_signable ? 4 : 0 ) + + (source_is_leading ? 2 : 0 ) + + (source_is_separate ? 1 : 0 ) ; - static tree source_sign_loc = gg_define_variable(UCHAR_P, "..mhnd_sign_loc", vs_file_static); - static tree source_sign_byte = gg_define_variable(UCHAR, "..mhnd_sign_byte", vs_file_static); - static tree dest_p = gg_define_variable(UCHAR_P, "..mhnd_dest", vs_file_static); // The destination data pointer - 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 + int switch_dest = (dest_is_signable ? 4 : 0 ) + + (dest_is_leading ? 2 : 0 ) + + (dest_is_separate ? 1 : 0 ) ; - gg_assign(dest_p, qualified_data_dest(destref)); + // Calculate the start of the source data: gg_assign(source_p, gg_add(member(sourceref.field, "data"), tsource.offset)); - if( sourceref.field->attr & signable_e ) + // Calculate the start of the destination data + gg_assign(dest_p, qualified_data_location(destref)); + + // Figure out exactly where the sign is, if any, and where the input + // digits are. + + switch( switch_source ) { - // The source is signable + case 0: + case 1: + case 2: + case 3: + // not signable + gg_assign(source_sign, integer_zero_node); + break; + case 4: + // signable, not leading, not separate + // Calculate location of the sign byte; it's the last byte of the data + gg_assign(source_sign_loc, + gg_add(source_p, + build_int_cst_type(SIZE_T, + sourceref.field->data.capacity-1))); + break; + case 5: + // signable, not leading, separate + // Calculate location of the sign byte; it's the last byte of the data + gg_assign(source_sign_loc, + gg_add(source_p, + build_int_cst_type(SIZE_T, + sourceref.field->data.capacity-1))); + break; + case 6: + // signable, leading, not separate + // Calculate location of the sign byte; it's the first byte of the data + gg_assign(source_sign_loc, source_p); + break; + case 7: + // signable, leading, separate + // Calculate location of the sign byte; it's the first byte of the data + gg_assign(source_sign_loc, source_p); + gg_increment(source_p); + break; + } + // At this point, the source sign is at source_sign_loc, and the digits + // start at source_p - if( !(sourceref.field->attr & leading_e) ) + // Let's learn what the source sign is + if( source_is_signable && source_is_separate ) + { + IF( gg_indirect(source_sign_loc), + eq_op, + build_int_cst_type(UCHAR, + charmap_source->mapped_character(ascii_minus)) ) { - // The sign location is trailing. Whether separate or not, the location - // is the final byte of the data: - gg_assign(source_sign_loc, gg_add(member( sourceref.field->var_decl_node, "data"), - tsource.offset)), - gg_assign(source_sign_loc, - gg_add(source_sign_loc, - build_int_cst_type(SIZE_T, - sourceref.field->data.capacity-1))); - if( (sourceref.field->attr & separate_e) ) - { - // We have trailing separate - } - else - { - // We have trailing internal - } + // Flag the source as negative + gg_assign(source_sign, integer_one_node); } - else + ELSE { - // The source sign location is in the leading position. - gg_assign(source_sign_loc, - gg_add(member(sourceref.field->var_decl_node, "data"), - tsource.offset)); - if( (sourceref.field->attr & separate_e) ) - { - // We have leading separate, so the first actual digit is at - // source_p+1. - gg_increment(source_p); - } - else - { - // We have leading internal - } + // Flag the source as positive + gg_assign(source_sign, integer_zero_node); } - // Pick up the byte that contains the sign data, whether internal or - // external: - gg_assign(source_sign_byte, gg_indirect(source_sign_loc)); - - if( !(sourceref.field->attr & separate_e) ) + ENDIF + } + if( source_is_signable && !source_is_separate ) + { + // We need to look for an indication that we are internally signed. We + // can tell that by checking to see if the digit is between '0' and '9' + IF( gg_indirect(source_sign_loc), + lt_op, + build_int_cst_type(UCHAR, + charmap_source->mapped_character(ascii_0)) ) + { + // The sign byte is less than '0', so we are negative + gg_assign(source_sign, integer_one_node); + } + ELSE { - // This is signable and internal, so we want to turn off the sign bit - // in the original source data - if( internal_codeset_is_ebcdic() ) + IF( gg_indirect(source_sign_loc), + gt_op, + build_int_cst_type(UCHAR, + charmap_source->mapped_character(ascii_9)) ) { - gg_assign(gg_indirect(source_sign_loc), - gg_bitwise_or(source_sign_byte, - build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT))); + // The sign byte is greater than '9', so we are negative + gg_assign(source_sign, integer_one_node); } - else + ELSE { - gg_assign(gg_indirect(source_sign_loc), - gg_bitwise_and( source_sign_byte, - build_int_cst_type( UCHAR, - ~NUMERIC_DISPLAY_SIGN_BIT))); + // The sign byte is betwixt '0' and '9', so we are positive + gg_assign(source_sign, integer_zero_node); } + ENDIF } - } - else - { - // The number is unsigned, so do nothing. + ENDIF } - // Let the shenanigans begin. + // We now know the source's sign, and where its digits are. - // We are now ready to output the very first byte. + // The first order of business is to move the digits into place. To do + // that, we need to know where things go in the destination: - // The first thing to do is see if we need to output a leading sign - // character - if( (destref.field->attr & signable_e) - && (destref.field->attr & leading_e) - && (destref.field->attr & separate_e) ) + switch( switch_dest ) { - // The output is signed, separate, and leading, so the first character - // needs to be either '+' or '-' - if( (sourceref.field->attr & separate_e) ) - { - // The source is signable/separate - // Oooh. Shiny. We already have that character. - gg_assign(gg_indirect(dest_p), source_sign_byte); - } - else - { - // The source is internal. Not that up above we set source_sign_byte - // even for source values that aren't signable - if( internal_codeset_is_ebcdic() ) - { - // We are working in EBCDIC - if( sourceref.field->attr & signable_e ) - { - IF( gg_bitwise_and( source_sign_byte, - build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT)), - eq_op, - build_int_cst_type( UCHAR, 0) ) - { - // The source was negative - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, EBCDIC_MINUS)); - - } - ELSE - { - // The source was positive - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, EBCDIC_PLUS)); - } - ENDIF - } - else - { - // The source is not signable, so the result is positive - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, EBCDIC_PLUS)); - } - } - else - { - // We are working in ASCII - if( sourceref.field->attr & signable_e ) - { - IF( gg_bitwise_and( source_sign_byte, - build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT)), - ne_op, - build_int_cst_type( UCHAR, 0) ) - { - // The source was negative - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, '-')); - - } - ELSE - { - // The source was positive - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, '+')); - } - ENDIF - } - else - { - // The source is not signable, so the result is positive - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, '+')); - } - } - } - gg_increment(dest_p); + case 0: + case 1: + case 2: + case 3: + // not signable + break; + case 4: + // signable, not leading, not separate + // Calculate location of the sign byte; it's the last byte of the data + gg_assign(dest_sign_loc, + gg_add(dest_p, + build_int_cst_type(SIZE_T, + destref.field->data.capacity-1))); + break; + case 5: + // signable, not leading, separate + // Calculate location of the sign byte; it's the last byte of the data + gg_assign(dest_sign_loc, + gg_add(dest_p, + build_int_cst_type(SIZE_T, + destref.field->data.capacity-1))); + break; + case 6: + // signable, leading, not separate + // Calculate location of the sign byte; it's the first byte of the data + gg_assign(dest_sign_loc, dest_p); + break; + case 7: + // signable, leading, separate + // Calculate location of the sign byte; it's the first byte of the data + gg_assign(dest_sign_loc, dest_p); + gg_increment(dest_p); + break; } - // We have the leading '+' or '-', assuming one is needed. We can - // now start outputting the digits to the left of the decimal place + // We can now start copying the digits to the left of the decimal place int dest_ldigits = (int)destref.field->data.digits - destref.field->data.rdigits; @@ -14492,10 +15566,9 @@ mh_numeric_display( cbl_refer_t &destref, // The destination has more ldigits than the source, and needs some // leading zeroes: picky_memset( dest_p, - internal_codeset_is_ebcdic() ? - EBCDIC_ZERO : '0' , + charmap_dest->mapped_character(ascii_0) , dest_ldigits - source_ldigits); - // With the leading zeros set, copy over the ldigits: + // With the leading zeros set, set the number of ldigits to copy: digit_count = source_ldigits; } else if( dest_ldigits == source_ldigits ) @@ -14503,7 +15576,7 @@ mh_numeric_display( cbl_refer_t &destref, // This is the Goldilocks zone. Everything is *just* right. digit_count = dest_ldigits; } - else + else // dest_ldigits < source_ldigits { // The destination is smaller than the source. We have to throw away the // the high-order digits of the source. If any of them are non-zero, then @@ -14519,8 +15592,7 @@ mh_numeric_display( cbl_refer_t &destref, IF( gg_indirect(source_p), ne_op, build_int_cst_type( UCHAR, - internal_codeset_is_ebcdic() ? - EBCDIC_ZERO : '0') ) + charmap_source->mapped_character(ascii_0)) ) { set_exception_code(ec_size_truncation_e); gg_assign(size_error, integer_one_node); @@ -14536,9 +15608,8 @@ mh_numeric_display( cbl_refer_t &destref, // remaining digits digit_count = dest_ldigits; } - - // The ldigits are in place. We now go the very similar exercise for the - // rdigits: + // We now have digit_count, which will cover the ldigits. Augment it by + // the number of rdigits: int dest_rdigits = destref.field->data.rdigits; int source_rdigits = sourceref.field->data.rdigits; @@ -14566,217 +15637,91 @@ mh_numeric_display( cbl_refer_t &destref, // over only the necessary rdigits, discarding the ones to the right. digit_count += dest_rdigits; } - - picky_memcpy(dest_p, source_p, digit_count); + picky_memcpy(dest_p, + source_p, + digit_count, + build_int_cst_type(UCHAR, + charmap_dest->mapped_character(ascii_0))); picky_memset( dest_p, - internal_codeset_is_ebcdic() ? - EBCDIC_ZERO : '0' , + charmap_dest->mapped_character(ascii_0), trailing_zeros); - // With the digits in place, we need to sort out what to do if the target - // is signable: - if( destref.field->attr & signable_e ) + // With the digits in place, the only thing left is to establish the sign + + switch( switch_dest ) { - if( (destref.field->attr & separate_e) - && !(destref.field->attr & leading_e) ) - { - // The target is separate/trailing, so we need to tack a '+' - // or '-' character - if( sourceref.field->attr & separate_e ) - { - // The source was separate, so we already have what we need in t - // source_sign_byte: - gg_assign(gg_indirect(dest_p), source_sign_byte); - gg_increment(dest_p); - } - else + case 0: + case 1: + case 2: + case 3: + // not signable, so there is nothing to do. + break; + case 4: + case 6: + // signable, not leading, not separate + if( charmap_dest->is_like_ebcdic() ) { - // The source is either internal, or unsigned - if( sourceref.field->attr & signable_e ) + IF( source_sign, ne_op, integer_zero_node ) { - // The source is signable/internal, so we need to extract the - // sign bit from source_sign_byte - if( internal_codeset_is_ebcdic() ) - { - IF( gg_bitwise_and( source_sign_byte, - build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT)), - eq_op, - build_int_cst_type( UCHAR, 0) ) - { - // The source was negative - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, EBCDIC_MINUS)); - - } - ELSE - { - // The source was positive - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, EBCDIC_PLUS)); - } - ENDIF - } - else - { - IF( gg_bitwise_and( source_sign_byte, - build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT)), - ne_op, - build_int_cst_type( UCHAR, 0) ) - { - // The source was negative - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, '-')); - - } - ELSE - { - // The source was positive - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, '+')); - } - ENDIF - } + // It's negative ebcdic, so we have to turn the bit off. + gg_assign(gg_indirect(dest_sign_loc), + gg_bitwise_and(gg_indirect(dest_sign_loc), + build_int_cst_type(UCHAR, + ~NUMERIC_DISPLAY_SIGN_BIT_EBCDIC))); } - else + ELSE { - // The source is unsigned, so dest is positive - gg_assign(gg_indirect(dest_p), - build_int_cst_type( UCHAR, - internal_codeset_is_ebcdic() ? - EBCDIC_PLUS : '+' )); } - } - gg_increment(dest_p); - } - else if( !(destref.field->attr & separate_e) ) - { - // The destination is signed/internal - if( destref.field->attr & leading_e ) - { - // The sign bit goes into the first byte: - gg_assign(dest_p, qualified_data_dest(destref)); + ENDIF } else { - // The sign bit goes into the last byte: - gg_decrement(dest_p); - } - if( sourceref.field->attr & signable_e ) - { - if( sourceref.field->attr & separate_e ) + IF( source_sign, ne_op, integer_zero_node ) { - // The source is separate, so source_sign_byte is '+' or '-' - IF( source_sign_byte, - eq_op, - build_int_cst_type(UCHAR, - internal_codeset_is_ebcdic() ? - EBCDIC_MINUS : '-') ) - { - // The source is negative, so turn the ASCII bit on - if( !internal_codeset_is_ebcdic() ) - { - gg_assign(gg_indirect(dest_p), - gg_bitwise_or(gg_indirect(dest_p), - build_int_cst_type( - UCHAR, - NUMERIC_DISPLAY_SIGN_BIT))); - - } - else - { - // It's ebcdic, so turn the sign bit OFF - gg_assign(gg_indirect(dest_p), - gg_bitwise_and(gg_indirect(dest_p), - build_int_cst_type( - UCHAR, - ~NUMERIC_DISPLAY_SIGN_BIT))); - } - } - ELSE - { - // The source is positive, so turn the EBCDIC bit ON: - if( internal_codeset_is_ebcdic() ) - { - gg_assign(gg_indirect(dest_p), - gg_bitwise_or(gg_indirect(dest_p), - build_int_cst_type( - UCHAR, - NUMERIC_DISPLAY_SIGN_BIT))); - } - } - ENDIF + // It's negative ascii, so we have to turn the bit on. + gg_assign(gg_indirect(dest_sign_loc), + gg_bitwise_or(gg_indirect(dest_sign_loc), + build_int_cst_type(UCHAR, + NUMERIC_DISPLAY_SIGN_BIT_ASCII))); } - else + ELSE { - // The source is signable/internal, so the sign bit is in - // source_sign_byte. Whatever it is, it has to go into dest_p: - if( internal_codeset_is_ebcdic() ) - { - // This is EBCDIC, so if the source_sign_byte bit is LOW, we - // clear that bit in dest_p high. - IF( gg_bitwise_and( source_sign_byte, - build_int_cst_type( - UCHAR, - NUMERIC_DISPLAY_SIGN_BIT)), - eq_op, - build_int_cst_type(UCHAR, 0) ) - { - // The source was negative, so make the dest negative - gg_assign(gg_indirect(dest_p), - gg_bitwise_and(gg_indirect(dest_p), - build_int_cst_type( - UCHAR, - ~NUMERIC_DISPLAY_SIGN_BIT))); - } - ELSE - ENDIF - } - else - { - // This is ASCII, so if the source_sign_byte bit is high, we - // set that bit in dest_p high. - IF( gg_bitwise_and( source_sign_byte, - build_int_cst_type( - UCHAR, - NUMERIC_DISPLAY_SIGN_BIT)), - ne_op, - build_int_cst_type(UCHAR, 0) ) - { - // The source was negative, so make the dest negative - gg_assign(gg_indirect(dest_p), - gg_bitwise_or(gg_indirect(dest_p), - build_int_cst_type( - UCHAR, - NUMERIC_DISPLAY_SIGN_BIT))); - } - ELSE - ENDIF - } } + ENDIF } - } - } + break; + case 5: + case 7: + // signable, not leading, separate + // signable, leading, separate + // Calculate location of the sign byte; it's the last byte of the data - if( (sourceref.field->attr & signable_e) - && !(sourceref.field->attr & separate_e)) - { - // The source is signable internal, so we need to restore the original - // sign byte in the original source data: - gg_assign(gg_indirect(source_sign_loc), source_sign_byte); + IF( source_sign, eq_op, integer_zero_node ) + { + gg_assign(gg_indirect(dest_sign_loc), + build_int_cst_type(UCHAR, + charmap_dest->mapped_character(ascii_plus))); + } + ELSE + { + gg_assign(gg_indirect(dest_sign_loc), + build_int_cst_type(UCHAR, + charmap_dest->mapped_character(ascii_minus))); + } + ENDIF + break; } moved = true; } return moved; - } + } //NUMERIC_DISPLAY_SIGN static bool -mh_little_endian( cbl_refer_t &destref, - cbl_refer_t &sourceref, - TREEPLET &tsource, - bool check_for_error, - tree size_error) +mh_little_endian( const cbl_refer_t &destref, + const cbl_refer_t &sourceref, + const TREEPLET &tsource, + bool check_for_error, + tree size_error) { bool moved = false; @@ -14818,7 +15763,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, @@ -14832,7 +15777,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, @@ -14844,9 +15789,9 @@ mh_little_endian( cbl_refer_t &destref, } static bool -mh_source_is_group( cbl_refer_t &destref, - cbl_refer_t &sourceref, - TREEPLET &tsrc) +mh_source_is_group( const cbl_refer_t &destref, + const cbl_refer_t &sourceref, + const TREEPLET &tsrc) { bool retval = false; if( sourceref.field->type == FldGroup && !(destref.field->attr & rjust_e) ) @@ -14855,13 +15800,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); @@ -14869,7 +15814,9 @@ mh_source_is_group( cbl_refer_t &destref, ELSE { // There are too-few source bytes: - gg_memset(tdest, build_int_cst_type(INT, internal_space), dbytes); + charmap_t *charmap = __gg__get_charmap(destref.field->codeset.encoding); + int dest_space = charmap->mapped_character(ascii_space); + gg_memset(tdest, build_int_cst_type(INT, dest_space), dbytes); gg_memcpy(tdest, tsource, sbytes); } ENDIF @@ -14878,6 +15825,141 @@ mh_source_is_group( cbl_refer_t &destref, return retval; } +static bool +mh_source_is_literalA(const cbl_refer_t &destref, + const cbl_refer_t &sourceref, + cbl_round_t rounded, + tree size_error) + { + bool moved = false; + if( sourceref.field->type == FldLiteralA ) + { + // We are moving a literal somewhere. Because a program-id can take + // variables of ANY LENGTH, we don't know the length of the target + // variable. We do, however, know its encoding. So, we are going to + // construct a string with the same number of characters as the source, but + // in the target variable's encoding. + + // We will then call a library routine that will be in charge of trimming + // and space filling. + + cbl_encoding_t encoding_dest = destref.field->codeset.encoding; + charmap_t *charmap_dest = __gg__get_charmap(encoding_dest); + + if( destref.refmod.from + || destref.refmod.len ) + { + // Let the move routine know to treat the destination as alphanumeric + gg_attribute_bit_set(destref.field, refmod_e); + } + + static char *buffer = NULL; + static size_t buffer_size = 0; + size_t source_length = sourceref.field->data.capacity; + + if( buffer_size < source_length ) + { + buffer_size = source_length; + buffer = static_cast<char *>(xrealloc(buffer, source_length)); + } + gcc_assert(buffer); + + cbl_figconst_t figconst = cbl_figconst_of( sourceref.field->data.initial); + if( figconst ) + { + // We are going to fill 'buffer' with a solid run of the figurative + // constant in the destination codeset. + char const_char = 0x7F; // Head off a compiler warning about + // // uninitialized variables + switch(figconst) + { + case normal_value_e : + // This is not possible, it says here in the fine print. + abort(); + break; + case low_value_e : + const_char = charmap_dest->low_value_character(); + break; + case zero_value_e : + const_char = charmap_dest->mapped_character(ascii_zero); + break; + case space_value_e : + const_char = charmap_dest->mapped_character(ascii_space); + break; + case quote_value_e : + const_char = charmap_dest->quote_character(); + break; + case high_value_e : + const_char = charmap_dest->high_value_character(); + break; + case null_value_e: + const_char = 0x00; + break; + } + memset(buffer, const_char, source_length); + } + else + { + // We are going to convert the source string to the destination codeset, + // and then copy it to 'buffer', trimming if necessary, and space-filling + // to the right if necessary: + cbl_encoding_t encoding_src = sourceref.field->codeset.encoding; + + size_t outlength; + const char *source_string = __gg__iconverter( encoding_src, + encoding_dest, + sourceref.field->data.initial, + source_length, + &outlength ); + // Copy over the converted string + memcpy( buffer, + source_string, + outlength ); + } + + // If the source is flagged ALL, or if we are setting the destination to + // a figurative constant, pass along the ALL bit: + int rounded_parameter = rounded + | ((sourceref.all || figconst ) ? REFER_ALL_BIT : 0); + + if( size_error ) + { + gg_assign(size_error, + gg_call_expr( INT, + "__gg__move_literala", + gg_get_address_of(destref.field->var_decl_node), + refer_offset(destref), + refer_size_dest(destref), + build_int_cst_type(INT, rounded_parameter), + build_string_literal(source_length, + buffer), + build_int_cst_type( SIZE_T, source_length), + NULL_TREE)); + } + else + { + gg_call ( INT, + "__gg__move_literala", + gg_get_address_of(destref.field->var_decl_node), + refer_offset(destref), + refer_size_dest(destref), + build_int_cst_type(INT, rounded_parameter), + build_string_literal(source_length, + buffer), + build_int_cst_type( SIZE_T, source_length), + NULL_TREE); + } + if( destref.refmod.from + || destref.refmod.len ) + { + // Return that value to its original form + gg_attribute_bit_clear(destref.field, refmod_e); + } + moved = true; + } + return moved; + } + static void move_helper(tree size_error, // This is an INT cbl_refer_t destref, @@ -14911,7 +15993,7 @@ move_helper(tree size_error, // This is an INT { // We are creating a copy of the original destination in case we clobber it // and have to restore it because of a computational error. - bool first_time = true; + static bool first_time = true; static size_t stash_size = 1024; if( first_time ) { @@ -14923,7 +16005,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, @@ -14936,7 +16018,7 @@ move_helper(tree size_error, // This is an INT //goto dont_be_clever; this will go through to the default. } - if( !moved ) + // if( !moved ) // commented out to quiet cppcheck { moved = mh_source_is_group(destref, sourceref, tsource); } @@ -14983,111 +16065,10 @@ move_helper(tree size_error, // This is an INT if( !moved && sourceref.field->type == FldLiteralA) { - SHOW_PARSE1 - { - SHOW_PARSE_INDENT - SHOW_PARSE_TEXT("__gg__move_literala") - } - - cbl_figconst_t figconst = cbl_figconst_of( sourceref.field->data.initial); - - if( destref.refmod.from - || destref.refmod.len ) - { - // Let the move routine know to treat the destination as alphanumeric - gg_attribute_bit_set(destref.field, refmod_e); - } - - static char *buffer = NULL; - static size_t buffer_size = 0; - size_t source_length = sourceref.field->data.capacity; - - if( buffer_size < source_length ) - { - buffer_size = source_length; - buffer = (char *)xrealloc(buffer, buffer_size); - } - - if( figconst ) - { - char const_char = 0x7F; // Head off a compiler warning about - // // uninitialized variables - switch(figconst) - { - case normal_value_e : - // This is not possible, it says here in the fine print. - abort(); - break; - case low_value_e : - const_char = ascii_to_internal(__gg__low_value_character); - break; - case zero_value_e : - const_char = internal_zero; - break; - case space_value_e : - const_char = internal_space; - break; - case quote_value_e : - const_char = ascii_to_internal(__gg__quote_character); - break; - case high_value_e : - const_char = ascii_to_internal(__gg__high_value_character); - break; - case null_value_e: - const_char = 0x00; - break; - } - memset(buffer, const_char, source_length); - } - else - { - memset( buffer, ascii_space, source_length); - memcpy( buffer, - sourceref.field->data.initial, - std::min(source_length, (size_t)sourceref.field->data.capacity) ); - for( size_t i=0; i<source_length; i++) - { - buffer[i] = ascii_to_internal(buffer[i]); - } - } - - int rounded_parameter = rounded - | ((sourceref.all || figconst ) ? REFER_ALL_BIT : 0); - - if( size_error ) - { - gg_assign(size_error, - gg_call_expr( INT, - "__gg__move_literala", - gg_get_address_of(destref.field->var_decl_node), - refer_offset_dest(destref), - refer_size_dest(destref), - build_int_cst_type(INT, rounded_parameter), - build_string_literal(source_length, - buffer), - build_int_cst_type( SIZE_T, source_length), - NULL_TREE)); - } - else - { - gg_call ( INT, - "__gg__move_literala", - gg_get_address_of(destref.field->var_decl_node), - refer_offset_dest(destref), - refer_size_dest(destref), - build_int_cst_type(INT, rounded_parameter), - build_string_literal(source_length, - buffer), - build_int_cst_type( SIZE_T, source_length), - NULL_TREE); - } - if( destref.refmod.from - || destref.refmod.len ) - { - // Return that value to its original form - gg_attribute_bit_clear(destref.field, refmod_e); - } - moved = true; + moved = mh_source_is_literalA(destref, + sourceref, + rounded, + size_error); } if( !moved ) @@ -15116,7 +16097,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, @@ -15130,7 +16111,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, @@ -15149,7 +16130,7 @@ move_helper(tree size_error, // This is an INT gg_attribute_bit_clear(destref.field, refmod_e); } - moved = true; + // moved = true; // commented out to quiet cppcheck } if( restore_on_error ) @@ -15228,77 +16209,72 @@ parser_print_string(const char *fmt, const char *ach) gg_printf(fmt, gg_string_literal(ach), NULL_TREE); } -#pragma GCC diagnostic push -#pragma GCC diagnostic ignored "-Wpedantic" +REAL_VALUE_TYPE +real_powi10 (uint32_t x) +{ + REAL_VALUE_TYPE ten, pow10; + real_from_integer (&ten, TYPE_MODE (FLOAT128), 10, SIGNED); + real_powi (&pow10, TYPE_MODE (FLOAT128), &ten, x); + return pow10; +} + +static char * -binary_initial_from_float128(cbl_field_t *field, int rdigits, _Float128 value) +binary_initial(cbl_field_t *field) { // This routine returns an xmalloced buffer designed to replace the // data.initial member of the incoming field char *retval = NULL; - char ach[128] = ""; - // We need to adjust value so that it has no decimal places - if( rdigits ) + uint32_t capacity; + uint32_t ddigits; + int32_t drdigits; + uint64_t attr; + FIXED_WIDE_INT(128) value128 = dirty_to_binary(field->data.original(), + capacity, + ddigits, + drdigits, + attr); + int scaled_rdigits = get_scaled_rdigits(field); + + int i = field->data.rdigits; + while( i<0 ) { - value *= get_power_of_ten(rdigits); + value128 = value128/10; + i += 1; } - // We need to make sure that the resulting string will fit into - // a number with 'digits' digits - // Keep in mind that pure binary types, like BINARY-CHAR, have no digits - if( field->data.digits ) + // We take the digits of value128, and put them into ach. We line up + // the rdigits, and we truncate the string after desired_digits + while(drdigits < scaled_rdigits) { - value = fmodf128(value, (_Float128)get_power_of_ten(field->data.digits)); + value128 *= 10; + drdigits += 1; } - - // We convert it to a integer string of digits: - strfromf128(ach, sizeof(ach), "%.0f", value); - if( strcmp(ach, "-0") == 0 ) + while(drdigits > scaled_rdigits) { - // Yes, negative zero can be a thing. Let's make it go away. - strcpy(ach, "0"); + value128 = value128 / 10; + drdigits -= 1; } - retval = (char *)xmalloc(field->data.capacity); + retval = static_cast<char *>(xmalloc(field->data.capacity)); + gcc_assert(retval); switch(field->data.capacity) { + tree type; case 1: - *(signed char *)retval = atoi(ach); - break; case 2: - *(signed short *)retval = atoi(ach); - break; case 4: - *(signed int *)retval = atoi(ach); - break; case 8: - *(signed long *)retval = atol(ach); - break; case 16: - { - __int128 val = 0; - bool negative = false; - for(size_t i=0; i<strlen(ach); i++) - { - if( ach[i] == '-' ) - { - negative = true; - continue; - } - val *= 10; - val += ach[i] & 0x0F; - } - if( negative ) - { - val = -val; - } - *(__int128 *)retval = val; - } + type = build_nonstandard_integer_type ( field->data.capacity + * BITS_PER_UNIT, 0); + native_encode_wide_int (type, value128, PTRCAST(unsigned char, retval), + field->data.capacity); break; default: fprintf(stderr, - "Trouble in initial_from_float128 at %s() %s:%d\n", + "Trouble in binary_initial at %s() %s:%d\n", __func__, __FILE__, __LINE__); @@ -15308,32 +16284,97 @@ binary_initial_from_float128(cbl_field_t *field, int rdigits, _Float128 value) return retval; } -#pragma GCC diagnostic pop static void -digits_from_float128(char *retval, cbl_field_t *field, size_t width, int rdigits, _Float128 value) +digits_from_int128( char *ach, + cbl_field_t *field, + uint32_t desired_digits, + FIXED_WIDE_INT(128) value128, // cppcheck-suppress unknownMacro + int32_t rdigits) + { + if( value128 < 0 ) + { + value128 = -value128; + } + + // 'rdigits' are the number of rdigits in value128. + + int scaled_rdigits = get_scaled_rdigits(field); + + int i = field->data.rdigits; + while( i<0 ) + { + value128 = value128/10; + i += 1; + } + + // We take the digits of value128, and put them into ach. We line up + // the rdigits, and we truncate the string after desired_digits + while(rdigits < scaled_rdigits) + { + value128 *= 10; + rdigits += 1; + } + while(rdigits > scaled_rdigits) + { + value128 = value128 / 10; + rdigits -= 1; + } + char conv[128]; + print_dec (value128, conv, SIGNED); + size_t len = strlen(conv); + + if( len<desired_digits ) + { + memset(ach, ascii_0, desired_digits - len); + strcpy(ach+desired_digits - len, conv); + } + else + { + strcpy(ach, conv + len-desired_digits); + } + } + +#if 0 +// This routine was replaced with digits_from_int1289. However, I am choosing +// to keep it around for a while, because it is a master class in manipulating +// REAL_VALUE_TYPE and FIXED_WIDE_INT + +static void +digits_from_float128(char *retval, cbl_field_t *field, size_t width, int rdigits, REAL_VALUE_TYPE value) { char ach[128]; // We need to adjust value so that it has no decimal places if( rdigits ) { - value *= get_power_of_ten(rdigits); + REAL_VALUE_TYPE pow10 = real_powi10 (rdigits); + real_arithmetic (&value, MULT_EXPR, &value, &pow10); } // We need to make sure that the resulting string will fit into // a number with 'digits' digits - - value = fmodf128(value, (_Float128)get_power_of_ten(field->data.digits)); + REAL_VALUE_TYPE pow10 = real_powi10 (field->data.digits); + mpfr_t m0, m1; + + mpfr_inits2 (FLOAT_MODE_FORMAT (TYPE_MODE (float128_type_node))->p, m0, m1, + NULL); + mpfr_from_real (m0, &value, MPFR_RNDN); + mpfr_from_real (m1, &pow10, MPFR_RNDN); + mpfr_clear_flags (); + mpfr_fmod (m0, m0, m1, MPFR_RNDN); + real_from_mpfr (&value, m0, + REAL_MODE_FORMAT (TYPE_MODE (float128_type_node)), + MPFR_RNDN); + real_convert (&value, TYPE_MODE (float128_type_node), &value); + mpfr_clears (m0, m1, NULL); + real_roundeven (&value, TYPE_MODE (float128_type_node), &value); + + bool fail = false; + FIXED_WIDE_INT(128) i + = FIXED_WIDE_INT(128)::from (real_to_integer (&value, &fail, 128), SIGNED); // We convert it to a integer string of digits: - strfromf128(ach, sizeof(ach), "%.0f", value); - if( strcmp(ach, "-0") == 0 ) - { - // Yes, negative zero can be a thing. Let's make it go away. - strcpy(ach, "0"); - } - - //fprintf(stderr, "digits_from_float128() %s %f %s ", field->name, (double)value, ach); + print_dec (i, ach, SIGNED); gcc_assert( strlen(ach) <= field->data.digits ); if( strlen(ach) < width ) @@ -15342,57 +16383,25 @@ digits_from_float128(char *retval, cbl_field_t *field, size_t width, int rdigits } strcpy(retval + (width-strlen(ach)), ach); } +#endif -char * -initial_from_float128(cbl_field_t *field, _Float128 value) +static char * +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, " %s\n", field->name); char *retval = NULL; - int rdigits; // Let's handle the possibility of a figurative constant - cbl_figconst_t figconst = cbl_figconst_of( field->data.initial); - //cbl_figconst_t figconst = (cbl_figconst_t)(field->attr & FIGCONST_MASK); + cbl_figconst_t figconst = cbl_figconst_of(field->data.initial); if( figconst ) { - int const_char = 0xFF; // Head off a compiler warning about uninitialized - // // variables - switch(figconst) - { - case normal_value_e : - // This really should never happen because normal_value_e is zero - abort(); - break; - case low_value_e : - const_char = ascii_to_internal(__gg__low_value_character); - break; - case zero_value_e : - const_char = internal_zero; - break; - case space_value_e : - const_char = internal_space; - break; - case quote_value_e : - const_char = ascii_to_internal(__gg__quote_character); - break; - case high_value_e : - if( __gg__high_value_character == DEGENERATE_HIGH_VALUE ) - { - const_char = __gg__high_value_character; - } - else - { - const_char = ascii_to_internal(__gg__high_value_character); - } - break; - case null_value_e: - break; - } + charmap_t *charmap = __gg__get_charmap(field->codeset.encoding); + int const_char = charmap->figconst_character(figconst); bool set_return = figconst != zero_value_e; if( !set_return ) { @@ -15410,12 +16419,22 @@ initial_from_float128(cbl_field_t *field, _Float128 value) } if( set_return ) { - retval = (char *)xmalloc(field->data.capacity); + retval = static_cast<char *>(xmalloc(field->data.capacity+1)); + gcc_assert(retval); memset(retval, const_char, field->data.capacity); - goto done; + retval[field->data.capacity] = '\0'; + return retval; } } + // ??? Refactoring the cases below that do not need 'value' would + // make this less ugly + REAL_VALUE_TYPE value; + if( field->data.etc_type == cbl_field_data_t::value_e ) + value = TREE_REAL_CST (field->data.value_of ()); + +#if 0 + int rdigits; // There is always the infuriating possibility of a P-scaled number if( field->attr & scaled_e ) { @@ -15428,7 +16447,9 @@ initial_from_float128(cbl_field_t *field, _Float128 value) // Our result has no decimal places, and we have to multiply the value // by 10**9 to get the significant bdigits where they belong. - value *= get_power_of_ten(field->data.digits + field->data.rdigits); + REAL_VALUE_TYPE pow10 + = real_powi10 (field->data.digits + field->data.rdigits); + real_arithmetic (&value, MULT_EXPR, &value, &pow10); } else { @@ -15438,7 +16459,8 @@ initial_from_float128(cbl_field_t *field, _Float128 value) // If our caller gave us 123000000, we need to divide // it by 1000000 to line up the 123 with where we want it to go: - value /= get_power_of_ten(-field->data.rdigits); + REAL_VALUE_TYPE pow10 = real_powi10 (-field->data.rdigits); + real_arithmetic (&value, RDIV_EXPR, &value, &pow10); } // Either way, we now have everything aligned for the remainder of the // processing to work: @@ -15448,17 +16470,18 @@ initial_from_float128(cbl_field_t *field, _Float128 value) // Not P-scaled rdigits = field->data.rdigits; } +#endif switch(field->type) { case FldNumericBin5: case FldIndex: - retval = binary_initial_from_float128(field, rdigits, value); + retval = binary_initial(field); break; case FldNumericBinary: { - retval = binary_initial_from_float128(field, rdigits, value); + retval = binary_initial(field); size_t left = 0; size_t right = field->data.capacity - 1; while(left < right) @@ -15470,99 +16493,99 @@ initial_from_float128(cbl_field_t *field, _Float128 value) case FldNumericDisplay: { - retval = (char *)xmalloc(field->data.capacity); + charmap_t *charmap = __gg__get_charmap(field->codeset.encoding); + + retval = static_cast<char *>(xmalloc(field->data.capacity)); + gcc_assert(retval); char *pretval = retval; char ach[128]; bool negative; - if( value < 0 ) + if( real_isneg (&value) ) { negative = true; - value = -value; + value = real_value_negate (&value); } else { negative = false; } - digits_from_float128(ach, field, field->data.digits, rdigits, value); - - char *digits = ach; + // Convert the data.initial to a __int128 + uint32_t capacity; + uint32_t ddigits; + int32_t drdigits; + uint64_t attr; + FIXED_WIDE_INT(128) value128 = dirty_to_binary(field->data.initial, + capacity, + ddigits, + drdigits, + attr); + digits_from_int128(ach, field, field->data.digits, value128, drdigits); + + const char *digits = ach; if( (field->attr & signable_e) && (field->attr & separate_e) && (field->attr & leading_e ) ) { + // This zoned decimal value is signable, separate, and leading. if( negative ) { - *pretval++ = internal_minus; + *pretval++ = charmap->mapped_character(ascii_minus); } else { - *pretval++ = internal_plus; + *pretval++ = charmap->mapped_character(ascii_plus); } } for(size_t i=0; i<field->data.digits; i++) { - *pretval++ = internal_zero + ((*digits++) & 0x0F); + // Start by assuming it's an value that can't be signed + *pretval++ = charmap->mapped_character(ascii_0) + ((*digits++) & 0x0F); } if( (field->attr & signable_e) && (field->attr & separate_e) && !(field->attr & leading_e ) ) { + // The value is signable, separate, and trailing if( negative ) { - *pretval++ = internal_minus; + *pretval++ = charmap->mapped_character(ascii_minus); } else { - *pretval++ = internal_plus; + *pretval++ = charmap->mapped_character(ascii_plus); } } if( (field->attr & signable_e) - && !(field->attr & separate_e) - && negative) + && !(field->attr & separate_e) ) { - if( field->attr & leading_e ) - { - if( internal_is_ebcdic ) - { - retval[0] &= ~NUMERIC_DISPLAY_SIGN_BIT; - } - else - { - retval[0] |= NUMERIC_DISPLAY_SIGN_BIT; - } - } - else - { - if( internal_is_ebcdic ) - { - pretval[-1] &= ~NUMERIC_DISPLAY_SIGN_BIT; - } - else - { - pretval[-1] |= NUMERIC_DISPLAY_SIGN_BIT; - } - } + // This value is signable, and not separate. So, the sign information + // goes into the first or last byte: + char *sign_location = field->attr & leading_e ? + retval : retval + field->data.digits - 1 ; + *sign_location = charmap->set_digit_negative(*sign_location, + negative); } break; } case FldPacked: { - retval = (char *)xmalloc(field->data.capacity); + retval = static_cast<char *>(xmalloc(field->data.capacity)); + gcc_assert(retval); char *pretval = retval; char ach[128]; bool negative; - if( value < 0 ) + if( real_isneg (&value) ) { - negative = true; - value = -value; + negative = true; + value = real_value_negate (&value); } else { - negative = false; + negative = false; } // For COMP-6 (flagged by separate_e), the number of required digits is @@ -15574,9 +16597,18 @@ initial_from_float128(cbl_field_t *field, _Float128 value) size_t ndigits = (field->attr & separate_e) ? field->data.capacity * 2 : field->data.capacity * 2 - 1; - digits_from_float128(ach, field, ndigits, rdigits, value); - - char *digits = ach; + uint32_t capacity; + uint32_t ddigits; + int32_t drdigits; + uint64_t attr; + FIXED_WIDE_INT(128) value128 = dirty_to_binary(field->data.initial, + capacity, + ddigits, + drdigits, + attr); + digits_from_int128(ach, field, ndigits, value128, drdigits); + + const char *digits = ach; for(size_t i=0; i<ndigits; i++) { if( !(i & 0x01) ) @@ -15617,17 +16649,16 @@ initial_from_float128(cbl_field_t *field, _Float128 value) { if( field->data.initial ) { - retval = (char *)xmalloc(field->data.capacity+1); + retval = static_cast<char *>(xmalloc(field->data.capacity+1)); + gcc_assert(retval); if( field->attr & hex_encoded_e) { memcpy(retval, field->data.initial, field->data.capacity); } else { - size_t buffer_size = 0; - size_t length = (size_t)field->data.capacity; - memset(retval, internal_space, length); - raw_to_internal(&retval, &buffer_size, field->data.initial, length); + size_t length = field->data.capacity; + memcpy(retval, field->data.initial, length); if( strlen(field->data.initial) < length ) { // If this is true, then the initial string must've been Z'xyz' @@ -15641,35 +16672,34 @@ initial_from_float128(cbl_field_t *field, _Float128 value) case FldNumericEdited: { - retval = (char *)xmalloc(field->data.capacity+1); + charmap_t *charmap = __gg__get_charmap(field->codeset.encoding); + retval = static_cast<char *>(xmalloc(field->data.capacity+1)); + gcc_assert(retval); if( field->data.initial && field->attr & quoted_e ) { - if( field->attr & quoted_e ) + // What the programmer says the value is, the value becomes, no + // matter how wrong it might be. + size_t length = std::min( (size_t)field->data.capacity, + strlen(field->data.initial)); + for(size_t i=0; i<length; i++) { - // What the programmer says the value is, the value becomes, no - // matter how wrong it might be. - size_t length = std::min( (size_t)field->data.capacity, - strlen(field->data.initial)); - for(size_t i=0; i<length; i++) - { - retval[i] = ascii_to_internal(field->data.initial[i]); - } - if( length < (size_t)field->data.capacity ) - { - memset( retval+length, - internal_space, - (size_t)field->data.capacity - length); - } + retval[i] = field->data.initial[i]; + } + if( length < (size_t)field->data.capacity ) + { + memset( retval+length, + charmap->mapped_character(ascii_space), + (size_t)field->data.capacity - length); } } else { // It's not a quoted string, so we use data.value: bool negative; - if( value < 0 ) + if( real_isneg (&value) ) { negative = true; - value = -value; + value = real_value_negate (&value); } else { @@ -15679,20 +16709,41 @@ initial_from_float128(cbl_field_t *field, _Float128 value) char ach[128]; memset(ach, 0, sizeof(ach)); memset(retval, 0, field->data.capacity); - size_t ndigits = field->data.capacity; - if( (field->attr & blank_zero_e) && value == 0 ) + if( (field->attr & blank_zero_e) && real_iszero (&value) ) { - memset(retval, internal_space, field->data.capacity); + memset( retval, + charmap->mapped_character(ascii_space), + field->data.capacity); } else { - digits_from_float128(ach, field, ndigits, rdigits, value); + size_t ndigits = field->data.capacity; + uint32_t capacity; + uint32_t ddigits; + int32_t drdigits; + uint64_t attr; + FIXED_WIDE_INT(128) value128 = dirty_to_binary(field->data.original(), + capacity, + ddigits, + drdigits, + attr); + digits_from_int128(ach, field, ndigits, value128, drdigits); + + // __gg__string_to_numeric_edited operates in ASCII space: __gg__string_to_numeric_edited( retval, ach, field->data.rdigits, negative, field->data.picture); + // So now we convert it to the target encoding: + size_t nbytes; + const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING, + field->codeset.encoding, + retval, + strlen(retval), + &nbytes); + strcpy(retval, converted); } } break; @@ -15700,17 +16751,24 @@ initial_from_float128(cbl_field_t *field, _Float128 value) case FldFloat: { - retval = (char *)xmalloc(field->data.capacity); + retval = static_cast<char *>(xmalloc(field->data.capacity)); + gcc_assert(retval); switch( field->data.capacity ) { case 4: - *(_Float32 *)retval = (_Float32) value; + value = real_value_truncate (TYPE_MODE (FLOAT), value); + native_encode_real (SCALAR_FLOAT_TYPE_MODE (FLOAT), &value, + PTRCAST(unsigned char, retval), 4, 0); break; case 8: - *(_Float64 *)retval = (_Float64) value; + value = real_value_truncate (TYPE_MODE (DOUBLE), value); + native_encode_real (SCALAR_FLOAT_TYPE_MODE (DOUBLE), &value, + PTRCAST(unsigned char, retval), 8, 0); break; case 16: - *(_Float128 *)retval = (_Float128) value; + value = real_value_truncate (TYPE_MODE (FLOAT128), value); + native_encode_real (SCALAR_FLOAT_TYPE_MODE (FLOAT128), &value, + PTRCAST(unsigned char, retval), 16, 0); break; } break; @@ -15718,13 +16776,38 @@ initial_from_float128(cbl_field_t *field, _Float128 value) case FldLiteralN: { + // This requires annotation. + + // The compiler originally used ASCII for field->data.initial. Later we + // expanded the field with the addition of the codeset.encoding + // For consistency in the parser processing, the FldLiteralN is arriving + // with the Object-Computer's character encoding, and field->data.initial + // is showing up encoded. + + // But on the run-time side, if the initial string is needed, it is + // invariably more useful in ASCII. Consider converting that string to + // a floating-point value, for example. + + // So, we are going to convert the data.initial string back to ASCII + // here. Later on, when we establish the run-time encoding, we will + // check for FldLiteralN and set that to ASCII as well. See + // actually_create_the_static_field(). + + size_t nbytes; + const char *converted = __gg__iconverter(field->codeset.encoding, + DEFAULT_SOURCE_ENCODING, + field->data.initial, + strlen(field->data.initial), + &nbytes); + retval = static_cast<char *>(xmalloc(strlen(field->data.initial)+1)); + gcc_assert(retval); + strcpy(retval, converted); break; } default: break; } - done: return retval; } @@ -15874,49 +16957,29 @@ actually_create_the_static_field( cbl_field_t *new_var, build_int_cst_type(SCHAR, new_var->data.rdigits) ); next_field = TREE_CHAIN(next_field); + // INT, "encoding", + // For FldLiteralN we force the encoding to be ASCII. + // See initial_from_initial() for an explanation. + CONSTRUCTOR_APPEND_ELT(CONSTRUCTOR_ELTS(constr), + next_field, + build_int_cst_type(INT, + new_var->type == FldLiteralN ? + DEFAULT_SOURCE_ENCODING + : new_var->codeset.encoding)); + next_field = TREE_CHAIN(next_field); + + // INT, "alphabet", + CONSTRUCTOR_APPEND_ELT(CONSTRUCTOR_ELTS(constr), + next_field, + build_int_cst_type(INT, new_var->codeset.alphabet)); + next_field = TREE_CHAIN(next_field); + DECL_INITIAL(new_var_decl) = constr; } static void psa_global(cbl_field_t *new_var) { - char *mname = cobol_name_mangler(new_var->name); - char ach[2*sizeof(cbl_name_t)]; - 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; @@ -15928,10 +16991,20 @@ psa_global(cbl_field_t *new_var) return; } - // global variables already have a cblc_field_t defined in constants.cc + // global variables already have a cblc_field_t defined in constants.cc. - strcpy(ach, "__gg__"); - strcat(ach, new_var->name); + // Finding their name is done by converting to lowercase, dashes become + // underscores, and "__ggsr__" is prepended. "filler" gets ignored. + + // To feed GDB-COBOL's requirements, we tack on this variable's index and + // this program's index number: + + char ach[2*sizeof(cbl_name_t)]; + + snprintf( ach, + sizeof(ach), + "__ggsr__%s", + new_var->name); for(size_t i=0; i<strlen(ach); i++) { ach[i] = _tolower(ach[i]); @@ -15941,16 +17014,6 @@ psa_global(cbl_field_t *new_var) } } - if( strcmp(new_var->name, "RETURN-CODE") == 0 ) - { - strcpy(ach, "__gg___11_return_code6"); - } - - if( strcmp(new_var->name, "UPSI-0") == 0 ) - { - strcpy(ach, "__gg___6_upsi_04"); - } - new_var->var_decl_node = gg_declare_variable(cblc_field_type_node, ach, NULL, vs_external_reference); // global variables already have a .data area defined. We can find that @@ -16026,12 +17089,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) @@ -16119,48 +17184,52 @@ psa_FldLiteralA(struct cbl_field_t *field ) // We are constructing a completely static constant structure. We know the // capacity. We'll create it from the data.initial. The cblc_field_t:data - // will be an ASCII/EBCDIC copy of the .initial data. The .initial will be - // left as ASCII. The var_decl_node will be an ordinary cblc_field_t, which - // means that at this point in time, a FldLiteralA can be used anywhere a - // FldGroup or FldAlphanumeric can be used. We are counting on the parser - // not allowing a FldLiteralA to be a left-hand-side variable. + // will be a copy of the .initial data. The var_decl_node will be an ordinary + // cblc_field_t, which means that at this point in time, a FldLiteralA can be + // used anywhere a FldGroup or FldAlphanumeric can be used. We are counting + // on the parser not allowing a FldLiteralA to be a left-hand-side variable. // First make room static size_t buffer_size = 1024; - static char *buffer = (char *)xmalloc(buffer_size); + static char *buffer = static_cast<char *>(xmalloc(buffer_size)); if( buffer_size < field->data.capacity+1 ) { buffer_size = field->data.capacity+1; - buffer = (char *)xrealloc(buffer, buffer_size); + buffer = static_cast<char *>(xrealloc(buffer, buffer_size)); } + gcc_assert(buffer); cbl_figconst_t figconst = cbl_figconst_of( field->data.initial ); gcc_assert(figconst == normal_value_e); - if( internal_codeset_is_ebcdic() ) - { - for( size_t i=0; i<field->data.capacity; i++ ) - { - buffer[i] = ascii_to_internal(field->data.initial[i]); - } - } - else - { - memcpy(buffer, field->data.initial, field->data.capacity); - } + memcpy(buffer, field->data.initial, field->data.capacity); buffer[field->data.capacity] = '\0'; // 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. @@ -16173,9 +17242,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]; @@ -16185,19 +17256,16 @@ psa_FldLiteralA(struct cbl_field_t *field ) vs_file_static); actually_create_the_static_field( field, - build_string_literal(field->data.capacity+1, + build_string_literal(field->data.capacity, buffer), - field->data.capacity+1, + field->data.capacity, field->data.initial, NULL_TREE, field->var_decl_node); - nvar += 1; - } - TRACE1 - { - TRACE1_INDENT - TRACE1_TEXT("Finished") - TRACE1_END + TREE_READONLY(field->var_decl_node) = 1; + TREE_USED(field->var_decl_node) = 1; + TREE_STATIC(field->var_decl_node) = 1; + DECL_PRESERVE_P (field->var_decl_node) = 1; } } #endif @@ -16212,6 +17280,8 @@ parser_local_add(struct cbl_field_t *new_var ) SHOW_PARSE_END } + CHECK_FIELD(new_var); + IF( member(new_var->var_decl_node, "data"), ne_op, gg_cast(UCHAR_P, null_pointer_node) ) @@ -16264,33 +17334,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.2u %s<%s> off:" HOST_SIZE_T_PRINT_UNSIGNED " " + "msiz:%u cap:%u dig:%u rdig:%d attr:0x" HOST_SIZE_T_PRINT_HEX_PURE " loc:%p", new_var->level, new_var->name, cbl_field_type_str(new_var->type), - 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, - (void*)new_var); + (fmt_size_t)new_var->attr, + static_cast<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 @@ -16299,12 +17370,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 ) { @@ -16318,7 +17389,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) { fprintf(stderr, " redefines:(%p)%s", - (void*)symbol_redefines(new_var), + static_cast<void*>(symbol_redefines(new_var)), symbol_redefines(new_var)->name); } @@ -16370,18 +17441,12 @@ parser_symbol_add(struct cbl_field_t *new_var ) { cbl_field_type_t incoming_type = new_var->type; - if( is_register_field(new_var) ) + if( new_var->attr & register_e ) { psa_global(new_var); goto done; } - if( new_var->type == FldBlob ) - { - psa_FldBlob(new_var); - goto done; - } - if( new_var->type == FldLiteralA ) { new_var->data.picture = ""; @@ -16390,18 +17455,12 @@ parser_symbol_add(struct cbl_field_t *new_var ) } size_t length_of_initial_string = 0; - const char *new_initial = NULL; - - // gg_printf("parser_symbol_add %s\n", build_string_literal( strlen(new_var->name)+1, new_var->name), NULL_TREE); - - // If we are dealing with an alphanumeric, and it is not hex_encoded, we - // want to convert to single-byte-encoding (if it happens to be UTF-8) and - // to EBCDIC, if EBCDIC is in force: + char *new_initial = NULL; // 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 @@ -16418,10 +17477,12 @@ parser_symbol_add(struct cbl_field_t *new_var ) TRACE1_TEXT_ABC(" (", cbl_field_type_str(new_var->type) ,")") if( new_var->type == FldLiteralN) { + const void *p1 = (new_var->data.initial); + const long *pldata = static_cast<const long *>(p1); + long ldata = *pldata; gg_fprintf( trace_handle, 1, " [%ld]", - build_int_cst_type(LONG, - *(const long *)new_var->data.initial)); + build_int_cst_type(LONG, ldata)); } TRACE1_END } @@ -16429,7 +17490,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); @@ -16469,23 +17530,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 ) @@ -16588,24 +17646,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 @@ -16614,7 +17663,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. @@ -16688,7 +17737,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, @@ -16708,10 +17757,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, @@ -16758,11 +17804,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 ) @@ -16785,55 +17830,47 @@ parser_symbol_add(struct cbl_field_t *new_var ) if( bytes_to_allocate ) { - if( new_var->attr & (intermediate_e) - && new_var->type != FldLiteralN - && new_var->type != FldLiteralA ) + // We need a unique name for the allocated data for this COBOL variable: + char achDataName[256]; + if( new_var->attr & external_e ) { - // We'll malloc() data in initialize_variable - data_area = null_pointer_node; + sprintf(achDataName, "%s", new_var->name); + } + else if( new_var->name[0] == '_' ) + { + // Avoid doubling up on leading underscore + sprintf(achDataName, + "%s_data_" HOST_SIZE_T_PRINT_UNSIGNED, + new_var->name, + (fmt_size_t)sv_data_name_counter++); } else { - // We need a unique name for the allocated data for this COBOL variable: - char achDataName[256]; - if( new_var->attr & external_e ) - { - sprintf(achDataName, "%s", new_var->name); - } - else if( new_var->name[0] == '_' ) - { - // Avoid doubling up on leading underscore - sprintf(achDataName, - "%s_data_%lu", - new_var->name, - sv_data_name_counter++); - } - else - { - sprintf(achDataName, - "_%s_data_%lu", - new_var->name, - sv_data_name_counter++); - } + sprintf(achDataName, + "_%s_data_" HOST_SIZE_T_PRINT_UNSIGNED, + new_var->name, + (fmt_size_t)sv_data_name_counter++); + } - if( new_var->attr & external_e ) - { - tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate); - new_var->data_decl_node = gg_define_variable( - array_type, - achDataName, - vs_external); - data_area = gg_get_address_of(new_var->data_decl_node); - } - else - { - tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate); - new_var->data_decl_node = gg_define_variable( - array_type, - achDataName, - vs_static); - data_area = gg_get_address_of(new_var->data_decl_node); - } + if( new_var->attr & external_e ) + { + tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate); + new_var->data_decl_node = gg_define_variable( + array_type, + achDataName, + vs_external); + data_area = gg_get_address_of(new_var->data_decl_node); + } + else + { + gg_variable_scope_t vs_scope = (new_var->attr & intermediate_e) + ? vs_stack : vs_static ; + tree array_type = build_array_type_nelts(UCHAR, bytes_to_allocate); + new_var->data_decl_node = gg_define_variable( + array_type, + achDataName, + vs_scope); + data_area = gg_get_address_of(new_var->data_decl_node); } } } @@ -16841,7 +17878,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) if( new_var->data.initial ) { - new_initial = initial_from_float128(new_var, new_var->data.value_of()); + new_initial = initial_from_initial(new_var); } if( new_initial ) { @@ -16853,6 +17890,10 @@ parser_symbol_add(struct cbl_field_t *new_var ) length_of_initial_string = new_var->data.capacity+1; break; + case FldLiteralN: + length_of_initial_string = strlen(new_initial)+1; + break; + default: length_of_initial_string = new_var->data.capacity; break; @@ -16860,50 +17901,19 @@ 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; - } - } + new_initial = static_cast<char *>(xmalloc(length_of_initial_string)); + gcc_assert(new_initial); + memcpy(new_initial, new_var->data.initial, length_of_initial_string); } 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); + free(new_initial); if( level_88_string ) { diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h index 2c135e8..802bba7 100644 --- a/gcc/cobol/genapi.h +++ b/gcc/cobol/genapi.h @@ -7,7 +7,7 @@ * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. - * * Redistributions in binary form must reproduce the above + * * Redistributions in binary form must reproduce the above` * copyright notice, this list of conditions and the following disclaimer * in the documentation and/or other materials provided with the * distribution. @@ -52,17 +52,26 @@ void parser_division( cbl_division_t division, void parser_enter_program(const char *funcname, bool is_function, int *retval); void parser_leave_program(); -void parser_accept( cbl_refer_t refer, special_name_t special_e); +void parser_accept( const cbl_refer_t &refer, + special_name_t special_e, + cbl_label_t *error, + cbl_label_t *not_error ); void parser_accept_exception( cbl_label_t *name ); void parser_accept_exception_end( cbl_label_t *name ); -void parser_accept_envar( cbl_refer_t refer, cbl_refer_t envar, - cbl_label_t *error, cbl_label_t *not_error ); -void parser_set_envar( cbl_refer_t envar, cbl_refer_t refer ); +void parser_accept_under_discussion(struct cbl_refer_t tgt, special_name_t special, + cbl_label_t *error, cbl_label_t *not_error ); +void parser_accept_envar( const cbl_refer_t &refer, + const cbl_refer_t &envar, + cbl_label_t *error, + cbl_label_t *not_error ); +void parser_set_envar( const cbl_refer_t &envar, const cbl_refer_t &refer ); -void parser_accept_command_line( cbl_refer_t tgt, cbl_refer_t src, - cbl_label_t *error, cbl_label_t *not_error ); -void parser_accept_command_line_count( cbl_refer_t tgt ); +void parser_accept_command_line(const cbl_refer_t &tgt, + const cbl_refer_t &src, + cbl_label_t *error, + cbl_label_t *not_error ); +void parser_accept_command_line_count( const cbl_refer_t &tgt ); void parser_accept_date_yymmdd( cbl_field_t *tgt ); void parser_accept_date_yyyymmdd( cbl_field_t *tgt ); @@ -72,7 +81,7 @@ void parser_accept_date_dow( cbl_field_t *tgt ); void parser_accept_date_hhmmssff( cbl_field_t *tgt ); void -parser_alphabet( cbl_alphabet_t& alphabet ); +parser_alphabet( const cbl_alphabet_t& alphabet ); void parser_alphabet_use( cbl_alphabet_t& alphabet ); @@ -81,13 +90,24 @@ parser_allocate( cbl_refer_t size_or_based, cbl_refer_t returning, bool initiali void parser_free( size_t n, cbl_refer_t refers[] ); +void parser_xml_parse( cbl_label_t *stmt, + cbl_refer_t input, + cbl_field_t *encoding, + cbl_field_t *validating, + bool returns_national, + cbl_label_t *from_proc, + cbl_label_t *to_proc ); + +void parser_xml_on_exception( cbl_label_t *name ); +void parser_xml_not_exception( cbl_label_t *name ); +void parser_xml_end( cbl_label_t *name ); + void parser_add( size_t nC, cbl_num_result_t *C, size_t nA, cbl_refer_t *A, cbl_arith_format_t format, cbl_label_t *error, - cbl_label_t *not_error, - void *compute_error = NULL); // This has to be cast to a tree pointer to int + cbl_label_t *not_error, void *compute_error = NULL); // This has to be cast to a tree pointer to int void parser_arith_error( cbl_label_t *name ); void parser_arith_error_end( cbl_label_t *name ); @@ -119,26 +139,26 @@ parser_divide(size_t nC, cbl_num_result_t *C, void *compute_error = NULL); // This has to be cast to a tree pointer to int void -parser_add( struct cbl_refer_t tgt, - struct cbl_refer_t a, struct cbl_refer_t b, +parser_add( const cbl_refer_t& tgt, + const cbl_refer_t& a, const cbl_refer_t& b, enum cbl_round_t = truncation_e ); void -parser_subtract( struct cbl_refer_t tgt, - struct cbl_refer_t a, struct cbl_refer_t b, +parser_subtract( const cbl_refer_t& tgt, + const cbl_refer_t& a, const cbl_refer_t& b, enum cbl_round_t = truncation_e ); void -parser_multiply( struct cbl_refer_t tgt, - struct cbl_refer_t a, struct cbl_refer_t b, +parser_multiply( const cbl_refer_t& tgt, + const cbl_refer_t& a, const cbl_refer_t& b, enum cbl_round_t = truncation_e ); void -parser_divide( struct cbl_refer_t quotient, - struct cbl_refer_t divisor, - struct cbl_refer_t dividend, +parser_divide( const cbl_refer_t& quotient, + const cbl_refer_t& divisor, + const cbl_refer_t& dividend, enum cbl_round_t = truncation_e, - struct cbl_refer_t remainder = cbl_refer_t()); + const cbl_refer_t& remainder = cbl_refer_t()); // void // parser_exponentiation( cbl_refer_t cref, @@ -174,7 +194,8 @@ parser_bitwise_op(struct cbl_field_t *tgt, void parser_classify( struct cbl_field_t *tgt, - struct cbl_refer_t srca, enum classify_t type ); + const struct cbl_refer_t &srca, + enum classify_t type ); void parser_op( struct cbl_refer_t cref, @@ -225,7 +246,7 @@ parser_perform_conditional_end( struct cbl_perform_tgt_t *tgt ); * For an in-line loop body, tgt->from.type == LblLoop, and tgt->to is NULL. */ void -parser_perform( struct cbl_perform_tgt_t *tgt, struct cbl_refer_t N ); +parser_perform( const cbl_perform_tgt_t *tgt, cbl_refer_t N ); /* * A simple UNTIL loop uses 1 varys element. For VARY loops, the @@ -253,18 +274,23 @@ parser_program_hierarchy( const struct cbl_prog_hier_t& hier ); void parser_end_program(const char *name=NULL); -void parser_sleep(cbl_refer_t seconds); +void parser_sleep(const cbl_refer_t &seconds); -void parser_exit( cbl_refer_t refer, ec_type_t = ec_none_e ); +void parser_exit( const cbl_refer_t& refer, ec_type_t = ec_none_e ); void parser_exit_section(void); void parser_exit_paragraph(void); void parser_exit_perform( struct cbl_perform_tgt_t *tgt, bool cycle ); void parser_exit_program(void); // exits back to COBOL only, else continue void +parser_exhibit( bool changed, bool named, + const std::vector<cbl_refer_t> &args ); +void parser_display( const struct cbl_special_name_t *upon, - struct cbl_refer_t args[], size_t n, - bool advance = DISPLAY_ADVANCE ); + const std::vector<cbl_refer_t> &args, + bool advance = DISPLAY_ADVANCE, + const cbl_label_t *not_error = nullptr, + const cbl_label_t *compute_error = nullptr ); void parser_display_field(cbl_field_t *fld); @@ -297,10 +323,10 @@ void parser_symbol_add(struct cbl_field_t *field); void -parser_initialize(struct cbl_refer_t refer, bool like_parser_symbol_add=false); +parser_initialize(const cbl_refer_t& refer, bool like_parser_symbol_add=false); void -parser_initialize_programs(size_t nprog, struct cbl_refer_t *progs); +parser_initialize_programs(size_t nprog, const struct cbl_refer_t *progs); void parser_label_label( struct cbl_label_t *label ); @@ -308,6 +334,9 @@ parser_label_label( struct cbl_label_t *label ); void parser_label_goto( struct cbl_label_t *label ); +callback_t * +parser_label_addr( struct cbl_label_t *label ); + void parser_goto( cbl_refer_t value, size_t narg, cbl_label_t * const labels[] ); @@ -315,7 +344,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); @@ -371,6 +400,12 @@ parser_file_rewrite( cbl_file_t *file, cbl_field_t *field, void parser_file_delete( cbl_file_t *file, bool sequentially ); +void parser_file_delete_file( cbl_label_t *name, + std::vector<cbl_file_t*> filenames ); +void parser_file_delete_on_exception( cbl_label_t *name ); +void parser_file_delete_not_exception( cbl_label_t *name ); +void parser_file_delete_end( cbl_label_t *name ); + #if condition_lists struct cbl_conditional_t { cbl_field_t *tgt; @@ -406,14 +441,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 +456,7 @@ parser_file_sort( cbl_file_t *file, void parser_file_merge( cbl_file_t *file, cbl_alphabet_t *alphabet, - size_t nkey, - cbl_key_t *keys, + const std::vector<cbl_key_t>& keys, size_t ninput, cbl_file_t **inputs, size_t noutput, @@ -450,7 +482,7 @@ parser_intrinsic_numval_c( cbl_field_t *f, void parser_intrinsic_subst( cbl_field_t *f, - cbl_refer_t& ref1, + const cbl_refer_t& ref1, size_t argc, cbl_substitute_t * argv ); @@ -492,12 +524,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,25 +550,18 @@ 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); void parser_call_exception( cbl_label_t *name ); 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, @@ -554,10 +579,11 @@ void parser_call( cbl_refer_t name, 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); +void parser_entry( const 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,11 +595,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); - -char *initial_from_float128(cbl_field_t *field, _Float128 value); - -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); @@ -582,6 +603,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 2796b7f..fa792d6 100644 --- a/gcc/cobol/gengen.cc +++ b/gcc/cobol/gengen.cc @@ -95,7 +95,6 @@ #include "toplev.h" #include "function.h" #include "fold-const.h" -#define HOWEVER_GCC_DEFINES_TREE 1 #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" #include "util.h" @@ -108,8 +107,6 @@ // Don't like it? Cry me a river. static const int ARG_LIMIT = 512; -static int sv_current_line_number; - // These are globally useful constants tree char_nodes[256]; @@ -137,6 +134,14 @@ tree bool_false_node; struct cbl_translation_unit_t gg_trans_unit; +// This set is used to prevent duplicated top-level program names from breaking +// the compiler when a source code module makes that mistake. +static std::unordered_set<std::string> names_we_have_seen; + +// This vector is used to process the function_decls at the point we leave +// the file. +static std::vector<tree> finalized_function_decls; + void gg_build_translation_unit(const char *filename) { @@ -258,14 +263,6 @@ gg_append_var_decl(tree var_decl) } } -location_t -location_from_lineno() - { - location_t loc; - loc = linemap_line_start(line_table, sv_current_line_number, 0); - return loc; - } - void gg_append_statement(tree stmt) { @@ -355,13 +352,12 @@ adjust_for_type(tree type) return retval; } -static char * -show_type(tree type) +gg_show_type(tree type) { if( !type ) { - cbl_internal_error("The given type is not NULL, and that's just not fair"); + cbl_internal_error("The given type is NULL, and that is just not fair"); } if( DECL_P(type) ) @@ -370,12 +366,19 @@ 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: + strcpy(ach2, gg_show_type(TREE_TYPE(type))); + sprintf(ach, "POINTER to %s", ach2); + break; + case VOID_TYPE: sprintf(ach, "VOID"); break; @@ -390,23 +393,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: @@ -416,7 +416,7 @@ show_type(tree type) return ach; } -void +tree gg_assign(tree dest, const tree source) { // This does the equivalent of a C/C++ "dest = source". When X1 is set, it @@ -427,6 +427,7 @@ gg_assign(tree dest, const tree source) // This routine also provides for the possibility that the assignment is // for a source that is a function invocation, as in // "dest = function_call()" + tree stmt = NULL_TREE; saw_pointer = false; tree dest_type = adjust_for_type(TREE_TYPE(dest)); @@ -449,11 +450,11 @@ gg_assign(tree dest, const tree source) if( okay ) { - tree stmt = build2_loc( location_from_lineno(), - MODIFY_EXPR, - TREE_TYPE(dest), - dest, - source); + stmt = build2_loc(gg_token_location(), + MODIFY_EXPR, + TREE_TYPE(dest), + dest, + source); gg_append_statement(stmt); } else @@ -462,20 +463,25 @@ gg_assign(tree dest, const tree source) // the same. This is a compilation-time error, since we want the caller to // have sorted the types out explicitly. If we don't throw an error here, // the gimple reduction will do so. Better to do it here, when we know - // where we are. - dbgmsg("Inefficient assignment"); - if(DECL_P(dest) && DECL_NAME(dest)) + // 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 @@ -517,11 +523,9 @@ 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", + cbl_internal_error("Somebody asked for the field %s.%s, which does not exist", IDENTIFIER_POINTER(DECL_NAME(base)), field_name); - gcc_unreachable(); } return field_decl; @@ -609,7 +613,7 @@ gg_add_field_to_structure(const tree type_of_field, const char *name_of_field, t tree id_of_field = get_identifier (name_of_field); // Create the new field: - tree new_field_decl = build_decl( location_from_lineno(), + tree new_field_decl = build_decl( gg_token_location(), FIELD_DECL, id_of_field, type_of_field); @@ -886,10 +890,11 @@ gg_create_assembler_name(const char *cobol_name) static char * gg_unique_in_function(const char *var_name, gg_variable_scope_t vs_scope) { - char *retval = (char *)xmalloc(strlen(var_name)+32); + char *retval = static_cast<char *>(xmalloc(strlen(var_name)+32)); if( (vs_scope == vs_stack || vs_scope == vs_static) ) { - sprintf(retval, "%s.%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 { @@ -929,7 +934,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 @@ -1020,10 +1025,7 @@ gg_declare_variable(tree type_decl, break; } DECL_INITIAL(var_decl) = initial_value; - if( unique_name ) - { - free(unique_name); - } + free(unique_name); return var_decl; } @@ -1038,7 +1040,7 @@ gg_define_from_declaration(tree var_decl) { // Having made sure the chain of variable declarations is nicely started, // it's time to actually define the storage with a decl_expression: - tree stmt = build1_loc (location_from_lineno(), + tree stmt = build1_loc (gg_token_location(), DECL_EXPR, TREE_TYPE(var_decl), var_decl); @@ -1769,7 +1771,7 @@ gg_build_relational_expression(tree operand_a, compare = LE_EXPR; break; } - tree relational_expression = build2_loc(location_from_lineno(), + tree relational_expression = build2_loc(gg_token_location(), compare, boolean_type_node, operand_a, @@ -1827,7 +1829,10 @@ gg_build_logical_expression(tree operand_a, } void -gg_create_goto_pair(tree *goto_expr, tree *label_expr, tree *label_addr, const char *name) +gg_create_goto_pair(tree *goto_expr, + tree *label_expr, + tree *label_addr, + const char *name) { // We are going to create a pair of expressions for our // caller. They are a matched set of goto/label expressions, @@ -1884,16 +1889,6 @@ gg_create_goto_pair(tree *goto_expr, } void -gg_goto_label_decl(tree label_decl) - { - tree goto_expr = build1_loc( location_from_lineno(), - GOTO_EXPR, - void_type_node, - label_decl); - gg_append_statement(goto_expr); - } - -void gg_create_goto_pair(tree *goto_expr, tree *label_expr) { // We are going to create a pair of expressions for our @@ -1933,7 +1928,7 @@ gg_create_goto_pair(tree *goto_expr, tree *label_expr, const char *name) void gg_goto(tree var_decl_pointer) { - tree go_to = build1_loc(location_from_lineno(), + tree go_to = build1_loc(gg_token_location(), GOTO_EXPR, void_type_node, var_decl_pointer); @@ -2148,18 +2143,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; @@ -2169,20 +2152,15 @@ gg_printf(const char *format_string, ...) { if(nargs >= ARG_LIMIT) { - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); - yywarn("###### You *must* be joking!"); - gcc_unreachable(); + cbl_internal_error("You *must* be joking"); } if( TREE_CODE(arg) >= 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_printf() again!"); - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); - gcc_unreachable(); + cbl_internal_error("You forgot to put a %<NULL_TREE%> at the end of a " + "%<gg_printf()%> again"); } args[nargs++] = arg; @@ -2193,17 +2171,15 @@ gg_printf(const char *format_string, ...) static tree function = NULL_TREE; if( !function ) { - function = gg_get_function_address(INT, "fprintf"); + function = gg_get_function_address(INT, "__gg__fprintf_stderr"); } - tree stmt = build_call_array_loc (location_from_lineno(), + tree stmt = build_call_array_loc (gg_token_location(), INT, function, nargs, args); gg_append_statement(stmt); - - gg_pop_context(); } tree @@ -2229,9 +2205,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!"); - gcc_unreachable(); + cbl_internal_error("You *must* be joking"); } args[argc++] = arg; @@ -2246,7 +2220,7 @@ gg_fprintf(tree fd, int nargs, const char *format_string, ...) function = gg_get_function_address(INT, "sprintf"); } - tree stmt = build_call_array_loc (location_from_lineno(), + tree stmt = build_call_array_loc (gg_token_location(), INT, function, argc, @@ -2293,7 +2267,7 @@ void gg_memset(tree dest, const tree value, tree size) { tree the_call = - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_MEMSET), 3, dest, @@ -2307,7 +2281,7 @@ gg_memchr(tree buf, tree ch, tree length) { tree the_call = fold_convert( pvoid_type_node, - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_MEMCHR), 3, buf, @@ -2322,7 +2296,7 @@ void gg_memcpy(tree dest, const tree src, tree size) { tree the_call = build_call_expr_loc( - location_from_lineno(), + gg_token_location(), builtin_decl_explicit (BUILT_IN_MEMCPY), 3, dest, @@ -2337,7 +2311,7 @@ void gg_memmove(tree dest, const tree src, tree size) { tree the_call = build_call_expr_loc( - location_from_lineno(), + gg_token_location(), builtin_decl_explicit (BUILT_IN_MEMMOVE), 3, dest, @@ -2370,7 +2344,7 @@ void gg_strcpy(tree dest, tree src) { tree the_call = - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_STRCPY), 2, dest, @@ -2383,7 +2357,7 @@ gg_strcmp(tree A, tree B) { tree the_call = fold_convert( integer_type_node, - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_STRCMP), 2, A, @@ -2415,7 +2389,7 @@ gg_strncmp(tree char_star_A, tree char_star_B, tree size_t_N) { tree the_call = fold_convert( integer_type_node, - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_STRNCMP), 3, char_star_A, @@ -2446,7 +2420,7 @@ gg_return(tree operand) { // When there is no operand, or if the function result is void, then // we just generate a return_expr. - stmt = build1_loc(location_from_lineno(), RETURN_EXPR, void_type_node, NULL_TREE); + stmt = build1_loc(gg_token_location(), RETURN_EXPR, void_type_node, NULL_TREE); } else { @@ -2456,7 +2430,7 @@ gg_return(tree operand) function_type, DECL_RESULT(current_function->function_decl), gg_cast(function_type, operand)); - stmt = build1_loc(location_from_lineno(), RETURN_EXPR, void_type_node, modify); + stmt = build1_loc(gg_token_location(), RETURN_EXPR, void_type_node, modify); } gg_append_statement(stmt); } @@ -2464,7 +2438,7 @@ gg_return(tree operand) void chain_parameter_to_function(tree function_decl, const tree param_type, const char *name) { - tree parm = build_decl (location_from_lineno(), + tree parm = build_decl (gg_token_location(), PARM_DECL, get_identifier (name), param_type); @@ -2482,167 +2456,113 @@ chain_parameter_to_function(tree function_decl, const tree param_type, const ch } } -void -gg_modify_function_type(tree function_decl, tree return_type) - { - tree fndecl_type = build_varargs_function_type_array( return_type, - 0, // No parameters yet - NULL); // And, hence, no types - TREE_TYPE(function_decl) = fndecl_type; - tree resdecl = build_decl (UNKNOWN_LOCATION, RESULT_DECL, NULL_TREE, return_type); - DECL_CONTEXT (resdecl) = function_decl; - DECL_RESULT (function_decl) = resdecl; - } +/* There are five ways that we use function_decls: -tree -gg_define_function_with_no_parameters(tree return_type, - const char *funcname, - const char *unmangled_name) - { - // This routine builds a function_decl, puts it on the stack, and - // gives it a context. + 1, We define a main() entry point. + 2. We call a function that turns out to be a static "t" function local to the source code module. + 3. We define an global "T" function, and possibly call it later. + 4. We call a function that we define later in the source code module. + 5. We call a function that ends up being an extern that is not defined in the source code module. - // At this time we don't know how many parameters this function expects, so - // we set things up and we'll tack on the parameters later. + Cases 3. and 4. turn out to require the same flags. Here are the combinations of + flags that are required for each flavor of function_decl. This was empirically + determind by compiling a C++ program with sample code for each type. - // Create the FUNCTION_TYPE for that array: - // int nparams = 1; - // tree types[1] = {VOID_P}; - // const char *names[1] = {"_p1"}; + | addressable | used | nothrow | static | external | public | no_instrument +main | | | | X | | X | X +local | X | X | X | X | | | X +external defined inside | X | X | X | X | | X | X +external defined elsewhere | X | X | | | X | X | - // tree fndecl_type = build_varargs_function_type_array( return_type, - // nparams, - // types); +*/ - tree fndecl_type = build_varargs_function_type_array( return_type, - 0, // No parameters yet - NULL); // And, hence, no types - // Create the FUNCTION_DECL for that FUNCTION_TYPE - tree function_decl = build_fn_decl (funcname, fndecl_type); +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 ) - { - // gg_trans_unit.function_stack is empty, so our context is - // the compilation module, and we need to be public: - DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl; - TREE_PUBLIC(function_decl) = 1; - } - else - { - // The stack has something in it, so we are building a nested function. - // Make the current function our context - DECL_CONTEXT (function_decl) = gg_trans_unit.trans_unit_decl; - TREE_PUBLIC(function_decl) = 0; +tree +gg_peek_fn_decl(const char *funcname, tree fndecl_type) + { + // When funcname is found in map_of_function_decls, this routine returns + // the type of the return value of that function decl. - // Append this function to the list of functions and variables - // associated with the computation module. - gg_append_var_decl(function_decl); + tree retval = NULL_TREE; + std::string key = function_decl_key(funcname, fndecl_type); + std::unordered_map<std::string, tree>::const_iterator it = + map_of_function_decls.find(key); + if( it != map_of_function_decls.end() ) + { + // This function_decl has already been defined. + retval = TREE_TYPE(TREE_TYPE(it->second)); } - - // Establish the RESULT_DECL for the function: - tree resdecl = build_decl (location_from_lineno(), RESULT_DECL, NULL_TREE, return_type); - DECL_CONTEXT (resdecl) = function_decl; - DECL_RESULT (function_decl) = resdecl; - - // The function_decl has a .function member, a pointer to struct_function. - // This is quietly, almost invisibly, extremely important. You need to - // call this routine after DECL_RESULT has been established: - - allocate_struct_function(function_decl, false); - - struct gg_function_t new_function = {}; - new_function.context_count = 0; - new_function.function_decl = function_decl; - new_function.our_name = IDENTIFIER_POINTER(DECL_NAME(function_decl)); - new_function.our_unmangled_name = xstrdup(unmangled_name); - new_function.function_address = gg_get_function_address(VOID, new_function.our_name); - - // Each program on the stack gets a unique identifier. This is used, for - // example, to make sure that static variables have unique names. - static size_t program_id = 0; - new_function.program_id_number = program_id++; - - // With everything established, put this function_decl on the stack - gg_trans_unit.function_stack.push_back(new_function); - - // All we need is a context, and we are ready to go: - gg_push_context(); - return function_decl; + return retval; } -void -gg_tack_on_function_parameters(tree function_decl, ...) +tree +gg_build_fn_decl(const char *funcname, tree fndecl_type) { - int nparams = 0; + tree function_decl; - tree types[ARG_LIMIT]; - const char *names[ARG_LIMIT]; - - va_list params; - va_start(params, function_decl); - for(;;) + std::string key = function_decl_key(funcname, fndecl_type); + std::unordered_map<std::string, tree>::const_iterator it = + map_of_function_decls.find(key); + if( it != map_of_function_decls.end() ) { - tree var_type = va_arg(params, tree); - if( !var_type ) - { - break; - } - - if( TREE_CODE(var_type) >= NUM_TREE_CODES) - { - // Warning: This test is not completely reliable, because a garbage - // byte could have a valid TREE_CODE. But it does help. - yywarn("You nitwit!"); - yywarn("You forgot to put a NULL_TREE at the end of a " - "gg_define_function() again!"); - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); - gcc_unreachable(); - } + // This function_decl has already been defined. Just return it; the caller + // is responsible for modifying it, if necessary. + function_decl = it->second; + } + else + { + // When creating a never-seen function_decl, we default to the type used + // for calling a function defined elsewhere. It's up to our caller to + // modify the flags, for example if this is part of creating a function. - const char *name = va_arg(params, const char *); + function_decl = build_fn_decl(funcname, fndecl_type); - types[nparams] = var_type; - names[nparams] = name; - nparams += 1; - if(nparams > ARG_LIMIT) - { - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); - yywarn("###### %d parameters? Really? Are you insane?",ARG_LIMIT+1); - gcc_unreachable(); - } - } - va_end(params); + // These are the bits shown in the table in the comment up above + TREE_ADDRESSABLE(function_decl) = 1; + TREE_USED(function_decl) = 1; + TREE_NOTHROW(function_decl) = 0; + TREE_STATIC(function_decl) = 0; + DECL_EXTERNAL (function_decl) = 1; + TREE_PUBLIC (function_decl) = 1; + DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 0; - // Chain the names onto the variables list: - for(int i=0; i<nparams; i++) - { - chain_parameter_to_function(function_decl, types[i], names[i]); + DECL_PRESERVE_P (function_decl) = 0; + DECL_ARTIFICIAL(function_decl) = 0; + map_of_function_decls[key] = function_decl; } + return function_decl; } -void -gg_define_function(tree return_type, const char *funcname, ...) +tree +gg_define_function( tree return_type, + const char *funcname, + const char *unmangled_name, + ...) { // This routine builds a function_decl, puts it on the stack, and // gives it a context. - // After the funcname, we expect the formal parameters: pairs of types/names - // terminated by a NULL_TREE + // At this time we don't know how many parameters this function expects, so + // we set things up and we'll tack on the parameters later. + + /* There is some bookkeeping we need to do to avoid crashing. + + It's possible for the source code to have two top-level functions with + the same name. This is a compile-time error, but the GCC processing gets + upset when it happens. We'll prevent it from happening here: + + */ int nparams = 0; @@ -2650,7 +2570,7 @@ gg_define_function(tree return_type, const char *funcname, ...) const char *names[ARG_LIMIT]; va_list params; - va_start(params,funcname); + va_start(params, unmangled_name); for(;;) { tree var_type = va_arg(params, tree); @@ -2663,11 +2583,8 @@ gg_define_function(tree return_type, const char *funcname, ...) { // Warning: This test is not completely reliable, because a garbage // byte could have a valid TREE_CODE. But it does help. - yywarn("You nitwit!"); - yywarn("You forgot to put a NULL_TREE at the end of a " - "gg_define_function() again!"); - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); - gcc_unreachable(); + cbl_internal_error("You forgot to put a %<NULL_TREE%> at the end of a " + "%<gg_define_function()%> again"); } const char *name = va_arg(params, const char *); @@ -2677,32 +2594,32 @@ gg_define_function(tree return_type, const char *funcname, ...) nparams += 1; if(nparams > ARG_LIMIT) { - yywarn("###### %10s in %s:%d", __func__, __FILE__,__LINE__ ); - yywarn("###### %d parameters? Really? Are you insane?", - ARG_LIMIT+1); - gcc_unreachable(); + cbl_internal_error("%d parameters? Really? Are you insane?", ARG_LIMIT+1); } } va_end(params); - // Create the FUNCTION_TYPE for that array: + char ach[32]; + std::unordered_set<std::string>::const_iterator it = + names_we_have_seen.find(funcname); + if( it != names_we_have_seen.end() ) + { + static int bum_counter = 1; + // We have seen this name before. Replace it with something unique: + sprintf(ach, "..no_dupes.%d", bum_counter++); + funcname = ach; + } + else + { + names_we_have_seen.insert(funcname); + } + tree fndecl_type = build_varargs_function_type_array( return_type, nparams, types); // Create the FUNCTION_DECL for that FUNCTION_TYPE - tree function_decl = build_fn_decl (funcname, fndecl_type); - - // Some of this stuff is magical, and is based on compiling C programs - // and just mimicking the results. - TREE_ADDRESSABLE(function_decl) = 1; - TREE_STATIC(function_decl) = 1; - DECL_EXTERNAL (function_decl) = 0; - DECL_PRESERVE_P (function_decl) = 0; - DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 1; - DECL_ARTIFICIAL(function_decl) = 0; - TREE_NOTHROW(function_decl) = 0; - TREE_USED(function_decl) = 1; + tree function_decl = gg_build_fn_decl (funcname, fndecl_type); // This code makes COBOL nested programs actual visible on the // source code "trans_unit_decl" level, but with non-public "static" @@ -2710,22 +2627,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); } @@ -2736,7 +2671,7 @@ gg_define_function(tree return_type, const char *funcname, ...) } // Establish the RESULT_DECL for the function: - tree resdecl = build_decl (location_from_lineno(), RESULT_DECL, NULL_TREE, return_type); + tree resdecl = build_decl (gg_token_location(), RESULT_DECL, NULL_TREE, return_type); DECL_CONTEXT (resdecl) = function_decl; DECL_RESULT (function_decl) = resdecl; @@ -2749,6 +2684,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. @@ -2760,6 +2698,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 @@ -2791,11 +2742,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__ ); - gcc_unreachable(); + cbl_internal_error("You forgot to put a %<NULL_TREE%> at the end of a " + "%<gg_define_function()%> again"); } const char *name = va_arg(params, const char *); @@ -2805,10 +2753,8 @@ 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?", + cbl_internal_error("%d parameters? Really? Are you insane?", ARG_LIMIT+1); - gcc_unreachable(); } } va_end(params); @@ -2855,7 +2801,7 @@ gg_get_function_decl(tree return_type, const char *funcname, ...) } // Establish the RESULT_DECL for the function: - tree resdecl = build_decl (location_from_lineno(), RESULT_DECL, NULL_TREE, return_type); + tree resdecl = build_decl (gg_token_location(), RESULT_DECL, NULL_TREE, return_type); DECL_CONTEXT (resdecl) = function_decl; DECL_RESULT (function_decl) = resdecl; @@ -2881,63 +2827,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. @@ -3076,14 +3032,12 @@ 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!"); - gcc_unreachable(); + cbl_internal_error("You *must* be joking"); } tree arg = va_arg(ap, tree); - if( !arg ) + if( arg == NULL_TREE ) { break; } @@ -3104,7 +3058,7 @@ gg_call_expr(tree return_type, const char *function_name, ...) tree the_func_addr = build1(ADDR_EXPR, build_pointer_type (TREE_TYPE(function_decl)), function_decl); - tree the_call = build_call_array_loc(location_from_lineno(), + tree the_call = build_call_array_loc(gg_token_location(), return_type, the_func_addr, nargs, @@ -3133,14 +3087,12 @@ 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!"); - gcc_unreachable(); + cbl_internal_error("You *must* be joking"); } tree arg = va_arg(ap, tree); - if( !arg ) + if( arg == NULL_TREE ) { break; } @@ -3161,7 +3113,7 @@ gg_call(tree return_type, const char *function_name, ...) tree the_func_addr = build1(ADDR_EXPR, build_pointer_type (TREE_TYPE(function_decl)), function_decl); - tree the_call = build_call_array_loc(location_from_lineno(), + tree the_call = build_call_array_loc(gg_token_location(), return_type, the_func_addr, nargs, @@ -3171,7 +3123,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[]] @@ -3186,9 +3138,9 @@ gg_call_expr_list(tree return_type, tree function_name, int param_count, tree ar // Avoid that with something like // gg_assign( dest, gg_call_expr_list(...) ); - tree the_call = build_call_array_loc(location_from_lineno(), + tree the_call = build_call_array_loc(gg_token_location(), return_type, - function_name, + function_pointer, param_count, args); // This routine returns the call_expr; the caller will have to deal with it @@ -3221,7 +3173,7 @@ void gg_exit(tree exit_code) { tree the_call = - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_EXIT), 1, exit_code); @@ -3232,7 +3184,7 @@ void gg_abort() { tree the_call = - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_ABORT), 0); gg_append_statement(the_call); @@ -3243,7 +3195,7 @@ gg_strlen(tree psz) { tree the_call = fold_convert( size_type_node, - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_STRLEN), 1, psz)); @@ -3255,7 +3207,7 @@ gg_strdup(tree psz) { tree the_call = fold_convert( build_pointer_type(char_type_node), - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_STRDUP), 1, psz)); @@ -3269,7 +3221,7 @@ gg_malloc(tree size) { tree the_call = fold_convert( pvoid_type_node, - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_MALLOC), 1, size)); @@ -3281,7 +3233,7 @@ gg_realloc(tree base, tree size) { tree the_call = fold_convert( pvoid_type_node, - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_REALLOC), 2, base, @@ -3305,7 +3257,7 @@ void gg_free(tree pointer) { tree the_call = - build_call_expr_loc(location_from_lineno(), + build_call_expr_loc(gg_token_location(), builtin_decl_explicit (BUILT_IN_FREE), 1, pointer); @@ -3348,7 +3300,8 @@ tree gg_array_of_size_t( size_t N, size_t *values) { tree retval = gg_define_variable(build_pointer_type(SIZE_T)); - gg_assign(retval, gg_cast(build_pointer_type(SIZE_T), gg_malloc( build_int_cst_type(SIZE_T, N * sizeof(size_t))))); + tree sz = build_int_cst_type(SIZE_T, N * int_size_in_bytes(SIZE_T)); + gg_assign(retval, gg_cast(build_pointer_type(SIZE_T), gg_malloc(sz))); for(size_t i=0; i<N; i++) { gg_assign(gg_array_value(retval, i), build_int_cst_type(SIZE_T, values[i])); @@ -3359,8 +3312,8 @@ gg_array_of_size_t( size_t N, size_t *values) tree gg_array_of_bytes( size_t N, unsigned char *values) { - tree retval = gg_define_variable(build_pointer_type(UCHAR)); - gg_assign(retval, gg_cast(build_pointer_type(UCHAR), gg_malloc( build_int_cst_type(UCHAR, N * sizeof(unsigned char))))); + tree retval = gg_define_variable(UCHAR_P); + gg_assign(retval, gg_cast(UCHAR_P, gg_malloc( build_int_cst_type(SIZE_T, N)))); for(size_t i=0; i<N; i++) { gg_assign(gg_array_value(retval, i), build_int_cst_type(UCHAR, values[i])); @@ -3405,18 +3358,6 @@ gg_string_literal(const char *string) return build_string_literal(strlen(string)+1, string); } -void -gg_set_current_line_number(int line_number) - { - sv_current_line_number = line_number; - } - -int -gg_get_current_line_number() - { - return sv_current_line_number; - } - tree gg_trans_unit_var_decl(const char *var_name) { @@ -3429,8 +3370,31 @@ gg_trans_unit_var_decl(const char *var_name) return NULL_TREE; } +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wsuggest-attribute=format" + +void +gg_insert_into_assembler(const char ach[]) + { + if( !optimize ) + { + // Create the required generic tag + tree asm_expr = build5_loc( gg_token_location(), + ASM_EXPR, + VOID, + build_string(strlen(ach), ach), + NULL_TREE, + NULL_TREE, + NULL_TREE, + NULL_TREE); + + // And insert it as a statement + gg_append_statement(asm_expr); + } + } + void -gg_insert_into_assembler(const char *format, ...) +gg_insert_into_assemblerf(const char *format, ...) { // Temporarily defeat all ASM_EXPR for optimized code per PR119214 // The correct solution using LABEL_DECL is forthcoming @@ -3449,18 +3413,31 @@ gg_insert_into_assembler(const char *format, ...) vsnprintf(ach, sizeof(ach), format, ap); va_end(ap); - // Create the required generic tag - tree asm_expr = build5_loc( location_from_lineno(), - ASM_EXPR, - VOID, - build_string(strlen(ach), ach), - NULL_TREE, - NULL_TREE, - NULL_TREE, - NULL_TREE); - //SET_EXPR_LOCATION (asm_expr, UNKNOWN_LOCATION); + gg_insert_into_assembler(ach); + } + } +#pragma GCC diagnostic pop - // And insert it as a statement - gg_append_statement(asm_expr); +static location_t sv_token_location_override = 0; + +void +token_location_override(location_t loc) + { + sv_token_location_override = loc; + } + +location_t +gg_token_location() + { + location_t retval; + if( sv_token_location_override ) + { + retval = sv_token_location_override; + sv_token_location_override = 0; } + else + { + retval = current_token_location(); + } + return retval; } diff --git a/gcc/cobol/gengen.h b/gcc/cobol/gengen.h index 8c1bc8d..e785ac7 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. @@ -495,7 +495,6 @@ void gg_create_goto_pair( tree *goto_expr, tree *label_expr, tree *label_addr, tree *label_decl); -void gg_goto_label_decl(tree label_decl); // Used for implementing SECTIONS and PARAGRAPHS. When you have a // void *pointer = &&label, gg_goto is the same as @@ -505,9 +504,6 @@ void gg_goto(tree pointer); void gg_record_statement_list_start(); tree gg_record_statement_list_finish(); -// These routines are in support of PERFORM PARAGRAPH -extern tree gg_get_function_decl(tree return_type, const char *funcname, ...); - // Used to call system exit() extern void gg_exit(tree exit_code); extern void gg_abort(); @@ -528,17 +524,21 @@ extern tree gg_indirect(tree pointer, tree byte_offset = NULL_TREE); extern tree gg_string_literal(const char *string); #define CURRENT_LINE_NUMBER (cobol_location().first_line) -location_t location_from_lineno(); - -// When set to true, use UNKNOWN_LOCATION instead of CURRENT_LINE_NUMBER -extern void gg_set_current_line_number(int line_number); -extern int gg_get_current_line_number(); +extern location_t gg_token_location(); +extern location_t current_token_location(); +extern location_t current_location_minus_one(); +extern void current_location_minus_one_clear(); +extern void token_location_override(location_t loc); extern tree gg_trans_unit_var_decl(const char *var_name); -tree gg_open(tree char_star_A, tree int_B); -tree gg_close(tree int_A); -tree gg_get_indirect_reference(tree pointer, tree offset); -void gg_insert_into_assembler(const char *format, ...); -void gg_modify_function_type(tree function_decl, tree return_type); +extern tree gg_open(tree char_star_A, tree int_B); +extern tree gg_close(tree int_A); +extern tree gg_get_indirect_reference(tree pointer, tree offset); + +extern void gg_insert_into_assembler(const char ach[]); +extern void gg_insert_into_assemblerf(const char *format, ...) ATTRIBUTE_PRINTF_1; + +extern char *gg_show_type(tree type); +extern void gg_leaving_the_source_code_file(); #endif diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc index 42f01cd..7d6ae8c 100644 --- a/gcc/cobol/genmath.cc +++ b/gcc/cobol/genmath.cc @@ -30,7 +30,6 @@ #include "cobol-system.h" #include "coretypes.h" #include "tree.h" -#define HOWEVER_GCC_DEFINES_TREE 1 #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" #include "util.h" @@ -43,7 +42,7 @@ #include "gengen.h" #include "structs.h" #include "../../libgcobol/gcobolio.h" -#include "../../libgcobol/libgcobol.h" +#include "../../libgcobol/charmaps.h" #include "show_parse.h" void @@ -54,7 +53,8 @@ set_up_on_exception_label(cbl_label_t *arithmetic_label) if( !arithmetic_label->structs.arith_error ) { arithmetic_label->structs.arith_error - = (cbl_arith_error_t *)xmalloc(sizeof(struct cbl_arith_error_t) ); + = static_cast<cbl_arith_error_t *> + (xmalloc(sizeof(struct cbl_arith_error_t))); // Set up the address pairs for this clause gg_create_goto_pair(&arithmetic_label->structs.arith_error->over.go_to, &arithmetic_label->structs.arith_error->over.label); @@ -74,8 +74,8 @@ set_up_compute_error_label(cbl_label_t *compute_label) if( !compute_label->structs.compute_error ) { compute_label->structs.compute_error - = (cbl_compute_error_t *) - xmalloc(sizeof(struct cbl_compute_error_t) ); + = static_cast<cbl_compute_error_t *> + (xmalloc(sizeof(struct cbl_compute_error_t))); compute_label->structs.compute_error->compute_error_code = gg_define_int(0); } @@ -97,8 +97,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) @@ -114,7 +114,6 @@ arithmetic_operation(size_t nC, cbl_num_result_t *C, { TRACE1_HEADER TRACE1_TEXT_ABC("calling ", operation, "") - TRACE1_END for(size_t ii=0; ii<nA; ii++) { TRACE1_INDENT @@ -131,7 +130,6 @@ arithmetic_operation(size_t nC, cbl_num_result_t *C, build_int_cst_type(SIZE_T, ii)); TRACE1_REFER("", B[ii], ""); } - TRACE1_END } // We need to split up cbl_num_result_t into two arrays, one for the refer_t @@ -139,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 ) @@ -181,6 +179,7 @@ arithmetic_operation(size_t nC, cbl_num_result_t *C, temp_field.data.rdigits = remainder->field->data.rdigits ; temp_field.data.initial = remainder->field->data.initial ; temp_field.data.picture = remainder->field->data.picture ; + temp_field.codeset = remainder->field->codeset ; parser_symbol_add(&temp_field); temp_remainder.field = &temp_field; @@ -209,7 +208,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, @@ -225,7 +224,6 @@ arithmetic_operation(size_t nC, cbl_num_result_t *C, { for(size_t ii=0; ii<nC; ii++) { - break; // Breaks on ADD 1 SUB2 GIVING SUB4 both PIC S9(3) COMP TRACE1_INDENT gg_fprintf( trace_handle, 1, "result: C[%ld]: ", @@ -255,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 @@ -309,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++) @@ -324,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++) @@ -339,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; @@ -401,7 +396,6 @@ fast_add( size_t nC, cbl_num_result_t *C, { Analyze(); // All targets are non-PICTURE binaries: - //gg_insert_into_assembler("# DUBNER addition START"); tree term_type = largest_binary_term(nA, A); if( term_type ) { @@ -415,7 +409,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++) @@ -423,7 +417,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); @@ -433,7 +427,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 ) { @@ -497,12 +491,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); @@ -510,7 +504,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)); } @@ -519,7 +513,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 ) { @@ -577,16 +571,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)); } @@ -595,7 +585,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 ) { @@ -621,7 +611,7 @@ static bool fast_divide(size_t nC, cbl_num_result_t *C, size_t nA, cbl_refer_t *A, size_t nB, cbl_refer_t *B, - cbl_refer_t remainder) + const cbl_refer_t &remainder) { bool retval = false; if( all_results_binary(nC, C) ) @@ -655,13 +645,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,9 +662,11 @@ fast_divide(size_t nC, cbl_num_result_t *C, // We now either divide into C[n] or assign dividend/divisor to C[n]: for(size_t i=0; i<nC; i++ ) { - tree dest_type = tree_type_from_size(C[i].refer.field->data.capacity, 0); - tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node, "data"), - refer_offset_dest(C[i].refer)); + tree dest_type = + tree_type_from_size(C[i].refer.field->data.capacity, 0); + tree dest_addr = gg_add(member( C[i].refer.field->var_decl_node, + "data"), + refer_offset(C[i].refer)); tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr); if( nB ) { @@ -689,16 +681,15 @@ fast_divide(size_t nC, cbl_num_result_t *C, } // This is where we handle any remainder, keeping in mind that for - // nB != 0, the actual dividend is in the value we have named "divisor". - // - // And, yes, I hate comments like that, too. + // nB != 0, the actual dividend is in the value we have named + // "divisor". // We calculate the remainder by calculating // dividend minus quotient * divisor if( remainder.field ) { - tree dest_addr = gg_add(member(remainder.field->var_decl_node, "data"), - refer_offset_dest(remainder)); + dest_addr = gg_add( member(remainder.field->var_decl_node, "data"), + refer_offset(remainder)); dest_type = tree_type_from_size(remainder.field->data.capacity, 0); ptr = gg_cast(build_pointer_type(dest_type), dest_addr); @@ -727,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) @@ -739,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) @@ -758,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, @@ -774,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: @@ -994,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 @@ -1216,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]; @@ -1239,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; @@ -1391,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; } } @@ -1414,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) @@ -1424,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) @@ -1434,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) @@ -1454,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, @@ -1470,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); @@ -1706,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 c0e6631..63f37f6 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -27,10 +27,12 @@ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ + +// cppcheck-suppress-file duplicateBreak + #include "cobol-system.h" #include "coretypes.h" #include "tree.h" -#define HOWEVER_GCC_DEFINES_TREE 1 #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" #include "util.h" @@ -43,26 +45,19 @@ #include "genutil.h" #include "structs.h" #include "../../libgcobol/gcobolio.h" -#include "../../libgcobol/libgcobol.h" #include "../../libgcobol/charmaps.h" #include "show_parse.h" #include "../../libgcobol/exceptl.h" #include "exceptg.h" -bool internal_codeset_is_ebcdic() { return gcobol_feature_internal_ebcdic(); } - bool exception_location_active = true; 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; @@ -74,7 +69,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,8 +105,25 @@ tree var_decl_treeplet_4s; // SIZE_T_P , "__gg__treeplet_4s" // wasn't successful figuring out how to create an actual NOP assembly language // instruction, I instead gg_assign(var_decl_nop, integer_zero_node) tree var_decl_nop; // int __gg__nop; + +// Indicates which routine main() called tree var_decl_main_called; // int __gg__main_called; +// Indicates the target label for an ENTRY statement +tree var_decl_entry_label; // void* __gg__entry_label + +#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) { @@ -227,11 +238,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 @@ -268,166 +285,159 @@ 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 + 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); + } + } - // Because this is for destination/receiving variables, OCCURS DEPENDING ON - // is not checked. +/* 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. - tree retval = gg_define_variable(SIZE_T); - gg_assign(retval, size_t_zero_node); + The return value for refstart is the actual offset, that is val(7:3) returns + the value 7-1, that is, 6. + */ +static +void +get_and_check_refstart_and_reflen( tree refstart,// LONG returned value + tree reflen, // LONG returned value + const cbl_refer_t &refer) + { + const cbl_enabled_exceptions_t& + enabled_exceptions( cdf_enabled_exceptions() ); - // We have a refer. - // At the very least, we have an constant offset - int all_flags = 0; - int all_flag_bit = 1; + 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 } @@ -435,121 +445,111 @@ 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. + */ + const cbl_enabled_exceptions_t& + enabled_exceptions( cdf_enabled_exceptions() ); + cbl_field_t *depending_on; + depending_on = cbl_field_of(symbol_at(odo->occurs.depending_on)); - // 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, - int *pflags = NULL) +static +tree +get_data_offset(const cbl_refer_t &refer, + int *pflags = NULL) { Analyze(); // This routine returns a tree which is the size_t offset to the data in the @@ -564,12 +564,10 @@ get_data_offset_source(cbl_refer_t &refer, // We have a refer. // At the very least, we have an constant offset int all_flags = 0; - int all_flag_bit = 1; - static tree value64 = gg_define_variable(LONG, ".._gdos_value64", vs_file_static); - - if( refer.nsubscript ) + if( refer.nsubscript() ) { + REFER("subscript"); // We have at least one subscript: // Figure we have three subscripts, so nsubscript is 3 @@ -585,8 +583,9 @@ get_data_offset_source(cbl_refer_t &refer, // Establish the field_t pointer for walking up through our ancestors: cbl_field_t *parent = refer.field; + int all_flag_bit = 1; // Note the backwards test, because refer->nsubscript is an unsigned value - for(size_t i=refer.nsubscript-1; i<refer.nsubscript; i-- ) + for(size_t i=refer.nsubscript()-1; i<refer.nsubscript(); i-- ) { // We need to search upward for an ancestor with occurs_max: while(parent) @@ -603,49 +602,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 @@ -657,161 +615,105 @@ 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) ) + const cbl_enabled_exceptions_t& + enabled_exceptions( cdf_enabled_exceptions() ); + 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) ) + { + // The subscript is too small + set_exception_code(ec_bound_subscript_e); + gg_assign(subscript, build_int_cst_type(TREE_TYPE(subscript), + 1)); + } + ELSE { - cbl_field_t *depending_on = cbl_field_of(symbol_at(parent->occurs.depending_on)); - get_integer_value(value64, depending_on); - IF( subscript, ge_op, value64 ) + IF( subscript, + 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 + + const cbl_enabled_exceptions_t& + enabled_exceptions( cdf_enabled_exceptions() ); + + 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))); } @@ -820,14 +722,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, @@ -856,16 +755,16 @@ get_binary_value( tree value, return; } - static tree pointer = gg_define_variable(UCHAR_P, "..gbv_pointer", vs_file_static); - static tree pend = gg_define_variable(UCHAR_P, "..gbv_pend", vs_file_static); - + static tree pointer = gg_define_variable( UCHAR_P, + "..gbv_pointer", + vs_file_static); switch(field->type) { case FldLiteralN: { 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 { @@ -895,8 +794,9 @@ get_binary_value( tree value, // We need to check early on for HIGH-VALUE and LOW-VALUE // Pick up the byte tree digit = gg_get_indirect_reference(source_address, NULL_TREE); - IF( digit, eq_op, build_int_cst(UCHAR, 0xFF) ) + IF( digit, eq_op, build_int_cst(UCHAR, DEGENERATE_HIGH_VALUE) ) { + // We are dealing with HIGH-VALUE if( hilo ) { gg_assign(hilo, integer_one_node); @@ -907,12 +807,14 @@ get_binary_value( tree value, build_int_cst_type( TREE_TYPE(rdigits), get_scaled_rdigits(field))); } - gg_assign(value, build_int_cst_type(TREE_TYPE(value), 0xFFFFFFFFFFFFFFFUL)); + gg_assign(value, build_int_cst_type(TREE_TYPE(value), + 0x7FFFFFFFFFFFFFFFUL)); } ELSE { - IF( digit, eq_op, build_int_cst(UCHAR, 0x00) ) + IF( digit, eq_op, build_int_cst(UCHAR, DEGENERATE_LOW_VALUE) ) { + // We are dealing with LOW-VALUE if( hilo ) { gg_assign(hilo, integer_minus_one_node); @@ -920,26 +822,25 @@ get_binary_value( tree value, } ELSE { - // Establish rdigits: + // We are dealing with an ordinary NumericDisplay value + gg_assign(pointer, source_address); + if( rdigits ) { gg_assign(rdigits, - build_int_cst_type( TREE_TYPE(rdigits), - get_scaled_rdigits(field))); + build_int_cst_type(TREE_TYPE(rdigits), + get_scaled_rdigits(field))); } - // Zero out the destination - gg_assign(value, gg_cast(TREE_TYPE(value), integer_zero_node)); - // Pick up a pointer to the source bytes: - - gg_assign(pointer, source_address); - - // This is the we-are-done pointer - gg_assign(pend, gg_add( pointer, - build_int_cst_type(SIZE_T, field->data.capacity))); - - static tree signbyte = gg_define_variable(UCHAR, "..gbv_signbyte", vs_file_static); - - // The big decision is whether or not the variable is signed: + // This will be the 128-bit value of the character sequence + static tree val128 = gg_define_variable(INT128, + "..gbv_val128", + vs_file_static); + // This is a pointer to the sign byte + static tree signp = gg_define_variable(UCHAR_P, + "..gbv_signp", + vs_file_static); + // We need to figure out where the sign information, if any is to be + // found: if( field->attr & signable_e ) { // The variable is signed @@ -949,12 +850,17 @@ get_binary_value( tree value, if( field->attr & leading_e) { // The first byte is '+' or '-' + gg_assign(signp, source_address); + // Increment pointer to point to the first actual digit gg_increment(pointer); } else { // The final byte is '+' or '-' - gg_decrement(pend); + gg_assign(signp, + gg_add(source_address, + build_int_cst_type( SIZE_T, + field->data.digits))); } } else @@ -962,219 +868,35 @@ get_binary_value( tree value, // The sign byte is internal if( field->attr & leading_e) { - // The first byte has the sign bit: - gg_assign(signbyte, - gg_get_indirect_reference(source_address, NULL_TREE)); - if( internal_codeset_is_ebcdic() ) - { - // We need to make sure the EBCDIC sign bit is ON, for positive - gg_assign(gg_get_indirect_reference(source_address, NULL_TREE), - gg_bitwise_or(signbyte, - build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT))); - } - else - { - // We need to make sure the ascii sign bit is Off, for positive - gg_assign(gg_get_indirect_reference(source_address, NULL_TREE), - gg_bitwise_and( signbyte, - build_int_cst_type( UCHAR, - ~NUMERIC_DISPLAY_SIGN_BIT))); - } + // The first byte has the sign bit. + gg_assign(signp, source_address); } else { - // The final byte has the sign bit: - gg_assign(signbyte, - gg_get_indirect_reference(source_address, - build_int_cst_type(SIZE_T, - field->data.capacity-1))); - if( internal_codeset_is_ebcdic() ) - { - // We need to make sure the EBCDIC sign bit is ON, for positive - gg_assign(gg_get_indirect_reference(source_address, - build_int_cst_type( SIZE_T, - field->data.capacity-1)), - gg_bitwise_or(signbyte, - build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT))); - } - else - { - // We need to make sure the ASCII sign bit is Off, for positive - gg_assign(gg_get_indirect_reference(source_address, - build_int_cst_type( SIZE_T, - field->data.capacity-1)), - gg_bitwise_and( signbyte, - build_int_cst_type( UCHAR, - ~NUMERIC_DISPLAY_SIGN_BIT))); - } + // The final byte has the sign bit. + gg_assign(signp, + gg_add(source_address, + build_int_cst_type( SIZE_T, + field->data.digits-1))); } } } - // We can now set up the byte-by-byte processing loop: - if( internal_codeset_is_ebcdic() ) - { - // We are working in EBCDIC - WHILE( pointer, lt_op, pend ) - { - // Pick up the byte - digit = gg_get_indirect_reference(pointer, NULL_TREE); - IF( digit, lt_op, build_int_cst_type(UCHAR, EBCDIC_ZERO) ) - { - // break on a non-digit - gg_assign(pointer, pend); - } - ELSE - { - IF( digit, gt_op, build_int_cst_type(UCHAR, EBCDIC_NINE) ) - { - // break on a non-digit - gg_assign(pointer, pend); - } - ELSE - { - // Whether ASCII or EBCDIC, the bottom four bits tell the tale: - // Multiply our accumulator by ten: - gg_assign(value, gg_multiply(value, build_int_cst_type(TREE_TYPE(value), 10))); - // And add in the current digit - gg_assign(value, - gg_add(value, gg_cast(TREE_TYPE(value), gg_bitwise_and( digit, - build_int_cst_type(UCHAR, 0x0F) )))); - gg_increment(pointer); - } - ENDIF - } - ENDIF - } - WEND - } else { - // We are working in ASCII: - WHILE( pointer, lt_op, pend ) - { - // Pick up the byte - digit = gg_get_indirect_reference(pointer, NULL_TREE); - // Whether ASCII or EBCDIC, the bottom four bits tell the tale: - // Multiply our accumulator by ten: - gg_assign(value, gg_multiply(value, build_int_cst_type(TREE_TYPE(value), 10))); - // And add in the current digit - gg_assign(value, gg_add(value, gg_cast(TREE_TYPE(value), gg_bitwise_and(digit, build_int_cst_type(UCHAR, 0x0F))))); - gg_increment(pointer); - } - WEND + // This value is unsigned, so just use the first location: + gg_assign(signp, source_address); } - // Value contains the binary value. The last thing is to apply -- and - // undo -- the signable logic: - - if( field->attr & signable_e ) - { - // The variable is signed - if( field->attr & separate_e ) - { - // The sign byte is separate - if( field->attr & leading_e) - { - // The first byte is '+' or '-' - if( internal_codeset_is_ebcdic() ) - { - // We are operating in EBCDIC, so we look for a 96 (is minus sign) - IF( gg_get_indirect_reference(source_address, NULL_TREE), - eq_op, - build_int_cst_type(UCHAR, 96) ) - { - gg_assign(value, gg_negate(value)); - } - ELSE - ENDIF - } - else - { - // We are operating in ASCII - IF( gg_get_indirect_reference(source_address, NULL_TREE), - eq_op, - build_int_cst_type(UCHAR, '-') ) - { - gg_assign(value, gg_negate(value)); - } - ELSE - ENDIF - } - } - else - { - // The final byte is '+' or '-' - if( internal_codeset_is_ebcdic() ) - { - // We are operating in EBCDIC, so we look for a 96 (is minus sign) - IF( gg_get_indirect_reference(source_address, build_int_cst_type(SIZE_T, field->data.capacity-1)), - eq_op, - build_int_cst_type(UCHAR, 96) ) - { - gg_assign(value, gg_negate(value)); - } - ELSE - ENDIF - } - else - { - // We are operating in ASCII - IF( gg_get_indirect_reference(source_address, build_int_cst_type(SIZE_T, field->data.capacity-1)), - eq_op, - build_int_cst_type(UCHAR, '-') ) - { - gg_assign(value, gg_negate(value)); - } - ELSE - ENDIF - } - } - } - else - { - // The sign byte is internal. Check the sign bit - if(internal_codeset_is_ebcdic()) - { - IF( gg_bitwise_and( signbyte, - build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT)), eq_op, build_int_cst_type(UCHAR, 0) ) - { - // The EBCDIC sign bit was OFF, so negate the result - gg_assign(value, gg_negate(value)); - } - ELSE - ENDIF - } - else - { - IF( gg_bitwise_and( signbyte, - build_int_cst_type( UCHAR, - NUMERIC_DISPLAY_SIGN_BIT)), ne_op, build_int_cst_type(UCHAR, 0) ) - { - // The ASCII sign bit was on, so negate the result - gg_assign(value, gg_negate(value)); - } - ELSE - ENDIF - } - // It's time to put back the original data: - if( field->attr & leading_e) - { - // The first byte has the sign bit: - gg_assign(gg_get_indirect_reference(source_address, NULL_TREE), - signbyte); - } - else - { - // The final byte has the sign bit: - gg_assign(gg_get_indirect_reference(source_address, - build_int_cst_type(SIZE_T, field->data.capacity-1)), - signbyte); - } - } - } + gg_assign(val128, + gg_call_expr( INT128, + "__gg__numeric_display_to_binary", + signp, + pointer, + build_int_cst_type(INT, field->data.digits), + build_int_cst_type(INT, field->codeset.encoding), + NULL_TREE)); + // Assign the value we got from the string to our "return" value: + gg_assign(value, gg_cast(TREE_TYPE(value), val128)); } ENDIF } @@ -1223,7 +945,9 @@ get_binary_value( tree value, vs_file_static); if( field->attr & signable_e ) { - IF( gg_array_value(gg_cast(build_pointer_type(SCHAR), source)), lt_op, gg_cast(SCHAR, integer_zero_node) ) + IF( gg_array_value(gg_cast(build_pointer_type(SCHAR), source)), + lt_op, + gg_cast(SCHAR, integer_zero_node) ) { gg_assign(extension, build_int_cst_type(UCHAR, 0xFF)); } @@ -1306,45 +1030,23 @@ get_binary_value( tree value, case FldPacked: { - // Zero out the destination: - gg_assign(value, gg_cast(TREE_TYPE(value), integer_zero_node)); - gg_assign(pointer, get_data_address(field, field_offset)); - gg_assign(pend, - gg_add(pointer, - build_int_cst_type(SIZE_T, field->data.capacity-1))); - - // Convert all but the last byte of the packed decimal sequence - WHILE( pointer, lt_op, pend ) - { - // Convert the first nybble - gg_assign(value, gg_multiply(value, build_int_cst_type(TREE_TYPE(value), 10))); - gg_assign(value, gg_add(value, gg_cast(TREE_TYPE(value), gg_rshift(gg_get_indirect_reference(pointer, NULL_TREE), build_int_cst(UINT, 4))))); - - // Convert the second nybble - gg_assign(value, gg_multiply(value, build_int_cst_type(TREE_TYPE(value), 10))); - gg_assign(value, gg_add(value, gg_cast(TREE_TYPE(value), gg_bitwise_and(gg_get_indirect_reference(pointer, NULL_TREE), build_int_cst_type(UCHAR, 0xF))))); - gg_increment(pointer); - } - WEND - - // This is the final byte: - gg_assign(value, gg_multiply(value, build_int_cst_type(TREE_TYPE(value), 10))); - gg_assign(value, gg_add(value, gg_cast(TREE_TYPE(value), gg_rshift(gg_get_indirect_reference(pointer, NULL_TREE), build_int_cst(UINT, 4))))); - - IF( gg_bitwise_and(gg_get_indirect_reference(pointer, NULL_TREE), build_int_cst_type(UCHAR, 0xF)), eq_op, build_int_cst_type(UCHAR, 0x0D) ) - { - gg_assign(value, gg_negate(value)); - } - ELSE + if( rdigits ) { - IF( gg_bitwise_and(gg_get_indirect_reference(pointer, NULL_TREE), build_int_cst_type(UCHAR, 0xF)), eq_op, build_int_cst_type(UCHAR, 0x0B) ) - { - gg_assign(value, gg_negate(value)); - } - ELSE - ENDIF + gg_assign(rdigits, + build_int_cst_type( TREE_TYPE(rdigits), + get_scaled_rdigits(field))); } - ENDIF + tree dest_type = TREE_TYPE(value); + + gg_assign(value, + gg_cast(dest_type, + gg_call_expr(INT128, + "__gg__packed_to_binary", + get_data_address( field, + field_offset), + build_int_cst_type(INT, + field->data.capacity), + NULL_TREE))); break; } @@ -1366,18 +1068,13 @@ get_binary_value( tree value, break; } - case FldAlphanumeric: - { - - } - - default: { - fprintf(stderr, "%s(): We know not how to" - " get a binary value from %s\n", - __func__, - cbl_field_type_str(field->type) ); + char *err = xasprintf("%s(): We know not how to" + " get a binary value from %s\n", + __func__, + cbl_field_type_str(field->type) ); + cbl_internal_error("%s", err); abort(); break; } @@ -1395,8 +1092,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); @@ -1420,17 +1117,14 @@ get_data_address( cbl_field_t *field, } } -// Ignore pedantic because we know 128-bit computation is not ISO C++14. -#pragma GCC diagnostic ignored "-Wpedantic" - -__int128 +FIXED_WIDE_INT(128) get_power_of_ten(int n) { // 2** 64 = 1.8E19 // 2**128 = 3.4E38 - __int128 retval = 1; + FIXED_WIDE_INT(128) retval = 1; static const int MAX_POWER = 19 ; - static const __int128 pos[MAX_POWER+1] = + static const unsigned long long pos[MAX_POWER+1] = { 1ULL, // 00 10ULL, // 01 @@ -1467,7 +1161,7 @@ get_power_of_ten(int n) else { // 19 through 38 is handled in a second step, because when this was written, - // GCC couldn't handle __int128 constants: + // GCC couldn't handle 128-bit constants: retval = pos[n/2]; retval *= retval; if( n & 1 ) @@ -1489,40 +1183,31 @@ 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); - __int128 power_of_ten = get_power_of_ten(N); - gg_assign(value, gg_multiply(value, build_int_cst_type( value_type, + FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten(N); + gg_assign(value, gg_multiply(value, wide_int_to_tree( value_type, power_of_ten))); } if( N < 0 ) { tree value_type = TREE_TYPE(value); - __int128 power_of_ten = get_power_of_ten(-N); + FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten(-N); if( check_for_fractional ) { - IF( gg_mod(value, build_int_cst_type( value_type, - power_of_ten)), + IF( gg_mod(value, wide_int_to_tree( value_type, + power_of_ten)), ne_op, gg_cast(value_type, integer_zero_node) ) { gg_assign(var_decl_rdigits, integer_one_node); } ELSE - gg_assign(var_decl_rdigits, integer_zero_node); ENDIF } - gg_assign(value, gg_divide(value, build_int_cst_type( value_type, + gg_assign(value, gg_divide(value, wide_int_to_tree( value_type, power_of_ten))); } } @@ -1701,7 +1386,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 ) { @@ -1719,7 +1404,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 ) { @@ -1745,7 +1430,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; @@ -1807,8 +1492,9 @@ set_exception_code_func(ec_type_t ec, int /*line*/, int from_raise_statement) } bool -process_this_exception(ec_type_t ec) +process_this_exception(const ec_type_t ec) { + const cbl_enabled_exceptions_t& enabled_exceptions( cdf_enabled_exceptions() ); bool retval; if( enabled_exceptions.match(ec) || !skip_exception_processing ) { @@ -1840,7 +1526,7 @@ copy_little_endian_into_place(cbl_field_t *dest, tree value, int rhs_rdigits, bool check_for_error, - tree &size_error) + const tree &size_error) { if( check_for_error ) { @@ -1865,12 +1551,12 @@ copy_little_endian_into_place(cbl_field_t *dest, } ENDIF - __int128 power_of_ten = get_power_of_ten( dest->data.digits - - dest->data.rdigits - + rhs_rdigits ); + FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten( dest->data.digits + - dest->data.rdigits + + rhs_rdigits ); IF( gg_cast(INT128, abs_value), ge_op, - build_int_cst_type(INT128, power_of_ten) ) + wide_int_to_tree(INT128, power_of_ten) ) { // Flag the size error gg_assign(size_error, integer_one_node); @@ -1916,7 +1602,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])); } @@ -1928,7 +1614,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])); } @@ -1940,7 +1626,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])); } @@ -1952,7 +1638,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])); } @@ -1997,7 +1683,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), @@ -2054,370 +1740,79 @@ 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); - } - for(size_t i=0; i<field->data.capacity; i++) - { - buffer[i] = ascii_to_internal(field->data.initial[i]); - } - buffer[field->data.capacity] = '\0'; + size_t buffer_length = field->data.capacity+1; + char *buffer = static_cast<char *>(xcalloc(1, buffer_length)); + + size_t charsout; + const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING, + field->codeset.encoding, + field->data.initial, + field->data.capacity, + &charsout); + memcpy(buffer, converted, field->data.capacity+1); return buffer; } bool -refer_is_clean(cbl_refer_t &refer) +refer_is_clean(const 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); - } +/* 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. - 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 shouldn't be called unless there is refmod involved. + */ static tree // size_t -refer_refmod_length(cbl_refer_t &refer) +refer_refmod_length(const cbl_refer_t &refer) { 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 - - 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)); - } - } + get_and_check_refstart_and_reflen( refstart, reflen, refer); - // Arrive here with valid values for refstart and reflen: + // Arrive here with a valid value for reflen: - return gg_cast(SIZE_T, reflen); - } - else - { - return size_t_zero_node; - } + return gg_cast(SIZE_T, reflen); } static tree // size_t -refer_fill_depends(cbl_refer_t &refer) +refer_fill_depends(const cbl_refer_t &refer) { + REFER(""); // 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 @@ -2433,90 +1828,59 @@ refer_fill_depends(cbl_refer_t &refer) } tree // size_t -refer_offset_dest(cbl_refer_t &refer) +refer_offset(const 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(const 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 ) @@ -2525,7 +1889,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)); } @@ -2533,113 +1897,74 @@ refer_size_dest(cbl_refer_t &refer) } tree // size_t -refer_offset_source(cbl_refer_t &refer, - int *pflags) +refer_size_dest(const 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) +refer_size_source(const 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(const 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 b2868f7..251b1c1 100644 --- a/gcc/cobol/genutil.h +++ b/gcc/cobol/genutil.h @@ -30,13 +30,6 @@ #ifndef _GENUTIL_H_ #define _GENUTIL_H_ -#define EBCDIC_MINUS (0x60) -#define EBCDIC_PLUS (0x4E) -#define EBCDIC_ZERO (0xF0) -#define EBCDIC_NINE (0xF9) - -bool internal_codeset_is_ebcdic(); - extern bool exception_location_active; extern bool skip_exception_processing; @@ -45,8 +38,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 +49,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 @@ -87,15 +77,15 @@ extern tree var_decl_treeplet_3s; // SIZE_T_P , "__gg__treeplet_3 extern tree var_decl_treeplet_4f; // cblc_field_pp_type_node , "__gg__treeplet_4f" extern tree var_decl_treeplet_4o; // SIZE_T_P , "__gg__treeplet_4o" extern tree var_decl_treeplet_4s; // SIZE_T_P , "__gg__treeplet_4s" - extern tree var_decl_nop; // int __gg__nop extern tree var_decl_main_called; // int __gg__main_called +extern tree var_decl_entry_label; // void* __gg__entry_label 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, @@ -104,10 +94,7 @@ void get_binary_value( tree value, tree get_data_address( cbl_field_t *field, tree offset); -#pragma GCC diagnostic push -#pragma GCC diagnostic ignored "-Wpedantic" -__int128 get_power_of_ten(int n); -#pragma GCC diagnostic pop +FIXED_WIDE_INT(128) get_power_of_ten(int n); void scale_by_power_of_ten_N(tree value, int N, bool check_for_fractional = false); @@ -124,9 +111,9 @@ void set_exception_code_func(ec_type_t ec, int line, int from_raise_statement=0); #define set_exception_code(ec) set_exception_code_func(ec, __LINE__) -bool process_this_exception(ec_type_t ec); +bool process_this_exception(const ec_type_t ec); #define CHECK_FOR_FRACTIONAL_DIGITS true -void get_integer_value(tree value, +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); @@ -136,7 +123,7 @@ void copy_little_endian_into_place(cbl_field_t *dest, tree value, int rhs_rdigits, bool check_for_error, - tree &size_error); + const tree &size_error); tree build_array_of_size_t( size_t N, const size_t *values); void parser_display_internal_field(tree file_descriptor, @@ -144,23 +131,14 @@ void parser_display_internal_field(tree file_descriptor, bool advance=DISPLAY_NO_ADVANCE); char *get_literal_string(cbl_field_t *field); -bool refer_is_clean(cbl_refer_t &refer); +bool refer_is_clean(const cbl_refer_t &refer); -tree refer_offset_source(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); +tree refer_offset(const cbl_refer_t &refer, + int *pflags=NULL); +tree refer_size_source(const cbl_refer_t &refer); +tree refer_size_dest(const 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(const cbl_refer_t &refer); void build_array_of_treeplets( int ngroup, size_t N, @@ -169,4 +147,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..0032b63 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} " @@ -42,6 +42,52 @@ "%{preprocess} " "%{dialect} " "%{include} " + "%{Wno-apply-commit} " + "%{Wno-file-code-set} " + "%{Wno-high-order-bit} " + "%{Wno-bad-line-directive} " + "%{Wno-bad-numeric} " + "%{Wno-binary-long-long} " + "%{Wno-call-giving} " + "%{Wno-cdf-dollar} " + "%{Wno-cdf-invalid-parameter} " + "%{Wno-cdf-name-not-found} " + "%{Wno-cobol-eject} " + "%{Wno-cobol-resume} " + "%{Wno-cobol-volatile} " + "%{Wno-comp-6} " + "%{Wno-comp-x} " + "%{Wno-copybook-found} " + "%{Wno-ec-unknown} " + "%{Wno-entry-convention} " + "%{Wno-iconv-error} " + "%{Wno-include-file-found} " + "%{Wno-include-file-not-found} " + "%{Wno-inspect-trailing} " + "%{Wno-length-of} " + "%{Wno-level-1-occurs} " + "%{Wno-level-78} " + "%{Wno-level-78-defined} " + "%{Wno-literal-concat} " + "%{Wno-locale-error} " + "%{Wno-move-corresponding} " + "%{Wno-move-pointer} " + "%{Wno-nllanginfo-error} " + "%{Wno-operator-space} " + "%{Wno-preprocessor-error} " + "%{Wno-procedure-not-found} " + "%{Wno-procedure-pointer} " + "%{Wno-replace-error} " + "%{Wno-returning-number} " + "%{Wno-segment-error} " + "%{Wno-segment-negative} " + "%{Wno-stop-number} " + "%{Wno-stray-indicator} " + "%{Wno-usage-typename} " + "%{Wno-recording-mode} " + "%{Wno-set-locale-to} " + "%{Wno-set-to-locale} " "%{nomain} " "%{!fsyntax-only:%(invoke_as)} " , 0, 0, 0}, + diff --git a/gcc/cobol/lang.opt b/gcc/cobol/lang.opt index 42c4020..bc56c01 100644 --- a/gcc/cobol/lang.opt +++ b/gcc/cobol/lang.opt @@ -38,87 +38,330 @@ 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 +Accept COBOL constructs used by non-ISO compilers. Enum Name(dialect_type) Type(int) UnknownError(Unrecognized COBOL dialect name: %qs) EnumValue -Enum(dialect_type) String(gcc) Value(0x04) Canonical +Enum(dialect_type) String(iso) Value(0x100) EnumValue -Enum(dialect_type) String(ibm) Value(0x01) +Enum(dialect_type) String(gcc) Value(0x01) Canonical EnumValue -Enum(dialect_type) String(mf) Value(0x02) +Enum(dialect_type) String(ibm) Value(0x02) EnumValue -Enum(dialect_type) String(gnu) Value(0x04) +Enum(dialect_type) String(mf) Value(0x04) + +EnumValue +Enum(dialect_type) String(gnu) Value(0x08) fcobol-exceptions Cobol Joined Separate Var(cobol_exceptions) --fcobol-exceptions=<n> Enable some exceptions by default +-fcobol-exceptions=<n> Enable some exceptions by default. copyext Cobol Joined Separate Var(cobol_copyext) Init(0) -Define alternative implicit copybook filename extension +Define alternative implicit copybook filename extension. + +;; warnings + +; Par78CdfDefinedW +Wlevel-78-defined +Cobol Warning Var(level_78_defined, 1) Init(1) +Warn if CDF defines Level 78 constant. + +; MfBinaryLongLong +Wbinary-long-long +Cobol Warning Var(binary_long_long, 1) Init(1) +Warn if BINARY-LONG-LONG is used. + +; MfCallGiving +Wcall-giving +Cobol Warning Var(call_giving, 1) Init(1) +Warn if CALL ... GIVING is used. + +; MfCdfDollar +Wcdf-dollar +Cobol Warning Var(cdf_dollar, 1) Init(1) +Warn if CDF %<$IF%> is used. + +; MfComp6 +Wcomp-6 +Cobol Warning Var(comp_6, 1) Init(1) +Warn if COMPUTATIONAL-6 is used. + +; MfCompX +Wcomp-x +Cobol Warning Var(comp_x, 1) Init(1) +Warn if COMPUTATIONAL is used with PICTURE X. + +; MfTrailing +Winspect-trailing +Cobol Warning Var(inspect_trailing, 1) Init(1) +Warn if INSPECT ... TRAILING is used. + +; MfLevel_1_Occurs +Wlevel-1-occurs +Cobol Warning Var(level_1_occurs, 1) Init(1) +Warn if Level 01 is used with OCCURS. + +; MfLevel78 +Wlevel-78 +Cobol Warning Var(level_78, 1) Init(1) +Warn if Level 78 is used. + +; MfMovePointer +Wmove-pointer +Cobol Warning Var(move_pointer, 1) Init(1) +Warn if MOVE POINTER is used. + +; MfReturningNum +Wreturning-number +Cobol Warning Var(returning_number, 1) Init(1) +Warn if RETURNING <number> is used. + +; MfUsageTypename +Wusage-typename +Cobol Warning Var(usage_typename, 1) Init(1) +Warn if USAGE IS TYPENAME is used. + +; ParNumstrW +Wbad-numeric +Cobol Warning Var(bad_numeric, 1) Init(1) +Warn if numeric string is invalid. + +; CdfParameterW +Wcdf-invalid-parameter +Cobol Warning Var(cdf_invalid_parameter, 1) Init(1) +Warn if referenced CDF PARAMETER is not defined. + +; CdfNotFoundW +Wcdf-name-not-found +Cobol Warning Var(cdf_name_not_found, 1) Init(1) +Warn if referenced CDF name is not defined. + +; LexInputN +Wcopybook-found +Cobol Warning Var(copybook_found, 1) Init(1) +Print message when copybook is processed. + +; EcUnknownW +Wec-unknown +Cobol Warning Var(ec_unknown, 1) Init(1) +Warn if unimplemented/unknown exception condition is referenced. + +; ParInfoI +Wentry-convention +Cobol Warning Var(entry_convention, 1) Init(1) +Print message when ENTRY CONVENTION is specified. + +; LexIncludeOkN +Winclude-file-found +Cobol Warning Var(include_file_found, 1) Init(1) +Print message when include file is processed. + +; ParLiteral2W +Wliteral-concat +Cobol Warning Var(literal_concat, 1) Init(1) +Warn if concatenated literals use different encodings. + +; ParLocaleW +Wlocale-error +Cobol Warning Var(locale_error, 1) Init(1) +Warn if locale(3) fails. + +; ParNoCorrespondingW +Wmove-corresponding +Cobol Warning Var(warn_corresponding, 1) Init(1) +Warn if COBOL MOVE has no corresponding fields. + +; ParLangInfoW +Wnllanginfo-error +Cobol Warning Var(nllanginfo_error, 1) Init(1) +Warn if nlanglanginfo(3) fails. + +; IbmLengthOf +Wlength-of +Cobol Warning Var(cobol_length_of, 1) Init(1) +Warn if LENGTH OF is used. + +; IbmProcedurePointer +Wprocedure-pointer +Cobol Warning Var(procedure_pointer, 1) Init(1) +Warn if PROCEDURE POINTER is used. + +; IbmSectionSegmentW +Wsegment +Cobol Warning Var(cobol_segment, 1) Init(1) +Warn if SECTION segments are used. + +; IsoResume +Wcobol-resume +Cobol Warning Var(cobol_resume, 1) Init(1) +Warn if resume is used (instead of error for IBM). + +;; unimplemented syntax + +; SynApplyCommit +Wapply-commit +Cobol Warning Var(apply_commit, 1) Init(1) +Warn if APPLY COMMIT is used. + +; SynHighOrderBit +Whigh-order-bit +Cobol Warning Var(high_order_bit, 1) Init(1) +Warn if HIGH-ORDER-LEFT HIGH-ORDER-RIGHT is used. + +; SynFileCodeSet +Wfile-code-set +Cobol Warning Var(file_code_set, 1) Init(1) +Warn if FILE CODE SET is used. + +; SynRecordingMode +Wrecording-mode +Cobol Warning Var(recording_mode, 1) Init(1) +Warn if RECORDING MODE is used. + +; SynSetLocaleTo +Wset-locale-to +Cobol Warning Var(set_locale_to, 1) Init(1) +Warn if SET LOCALE ... TO is used. + +; SynSetToLocale +Wset-to-locale +Cobol Warning Var(set_to_locale, 1) Init(1) +Warn if SET ... TO LOCALE is used. + +;; errors to warnings + +; LexLineE +Wbad-line-directive +Cobol Warning Var(bad_line_directive, 1) Init(1) +Warn if a line directive is malformed (instead of error). + +; IbmEqualAssignE +Wequal-assign +Cobol Warning Var(equal_assign, 1) Init(1) +Warn if EQUAL used as assignment operator (instead of error). + +; ParIconvE +Wiconv-error +Cobol Warning Var(iconv_error, 1) Init(1) +Warn if iconv(3) cannot convert between encodings (instead of error). + +; LexIncludeE +Winclude-file-not-found +Cobol Warning Var(include_file_not_found, 1) Init(1) +Warn if include file is not found (instead of error). + +; LexPreprocessE +Wpreprocessor-error +Cobol Warning Var(preprocessor_error, 1) Init(1) +Warn if a preprocessor fails (instead of error). + +; ParUnresolvedProcE +Wprocedure-not-found +Cobol Warning Var(procedure_not_found, 1) Init(1) +Warn if a referenced procedure is not found (instead of error). + +; LexReplaceE +Wreplace-error +Cobol Warning Var(replace_error, 1) Init(1) +Warn if REPLACE cannot be processed (instead of error). + +; IbmSectionRangeE +Wsegment-error +Cobol Warning Var(segment_error, 1) Init(1) +Warn if a SEGMENT section is invalid (instead of error). + +; IbmSectionNegE +Wsegment-negative +Cobol Warning Var(segment_negative, 1) Init(1) +Warn if a SEGMENT range is negative (instead of error). + +; LexIndicatorE +Wstray-indicator +Cobol Warning Var(stray_indicator, 1) Init(1) +Warn if indicator column has no recognized meaning (instead of error). + +; LexSeparatorE +Woperator-space +Cobol Warning Var(operator_space, 1) Init(1) +Warn if relational operator not followed by space (instead of error). + +; IbmEjectE +Wcobol-eject +Cobol Warning Var(cobol_eject, 1) Init(1) +Warn if IBM-style EJECT is used (instead of error). + +; IbmStopNumber +Wstop-number +Cobol Warning Var(stop_number, 1) Init(1) +Warn if IBM-style STOP <number> is used (instead of error). + +; IbmVolatileE +Wcobol-volatile +Cobol Warning Var(cobol_volatile, 1) Init(1) +Warn if VOLATILE is used (instead of error if -dialect ibm). + +;; end error-suppression options fdefaultbyte Cobol RejectNegative Joined Separate UInteger Var(cobol_default_byte) -Set Working-Storage data items to the supplied value +Set Working-Storage data items to the supplied value. fflex-debug Cobol Var(yy_flex_debug, 1) Init(0) -Enable Cobol lex debugging +Enable Cobol lex debugging. 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. findicator-column Cobol RejectNegative Joined Separate UInteger Var(indicator_column) Init(0) IntegerRange(0, 8) --findicator-column=<n> Column after which Region A begins +-findicator-column=<n> Column after which Region A begins. 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 +-finternal-ebcdic Internal processing is in EBCDIC Code Page 1140. fstatic-call Cobol Var(cobol_static_call, 1) Init(1) -Enable/disable static linkage for CALL literals +Enable/disable static linkage for CALL literals. ftrace-debug Cobol Var(cobol_trace_debug, 1) Init(0) -Enable Cobol parser debugging +Enable Cobol parser debugging. fyacc-debug Cobol Var(yy_debug, 1) Init(0) -Enable Cobol yacc debugging +Enable Cobol yacc debugging. preprocess Cobol Joined Separate Var(cobol_preprocess) -preprocess <source_filter> before compiling +Preprocess <source_filter> before compiling. iprefix Cobol Joined Separate ; Documented in C include -Cobol Joined Separate Var(cobol_include) +Cobol Joined Separate ; Documented in C isysroot @@ -131,14 +374,14 @@ Cobol Joined Separate main Cobol --main The first program-id in the next source file is called by a generated main() entry point +-main The first program-id in the next source file is called by a generated main() entry point. main= Cobol Joined Var(cobol_main_string) --main=<source_file> source_file/PROGRAM-ID is called by the generated main() +-main=<source_file> source_file/PROGRAM-ID is called by the generated main(). nomain Cobol --nomain No main() function is created from COBOL source files +-nomain No main() function is created from COBOL source files. ; This comment is to ensure we retain the blank line above. diff --git a/gcc/cobol/lang.opt.urls b/gcc/cobol/lang.opt.urls index 6a5dc1c..e628ae5 100644 --- a/gcc/cobol/lang.opt.urls +++ b/gcc/cobol/lang.opt.urls @@ -8,19 +8,19 @@ UrlSuffix(gcc/Preprocessor-Options.html#index-D-1) ; duplicate: 'gcc/Overall-Options.html#index-E' I -UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) +UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) LangUrlSuffix_Algol68(ga68/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) +preprocess +UrlSuffix(gcc/Overall-Options.html#index-preprocess) 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..58cd3ff 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" @@ -37,15 +38,24 @@ extern int yy_flex_debug; -static struct { - bool first_file, explicitly; - int column, right_margin; - bool inference_pending() { - bool tf = first_file && !explicitly; - first_file = false; - return tf; +source_format_t& cdf_source_format(); + +void +source_format_t::infer( const char *bol, bool want_reference_format ) { + if( bol ) { + left = 7; + if( want_reference_format ) { + right = 73; + } } -} indicator = { true, false, 0, 0 }; + dbgmsg("%s:%d: %s format detected", __func__, __LINE__, + description()); +} + + +// public source format test functions +bool is_fixed_format() { return cdf_source_format().is_fixed(); } +bool is_reference_format() { return cdf_source_format().is_reffmt(); } static bool debug_mode = false; @@ -61,11 +71,10 @@ static bool debug_mode = false; */ static inline int left_margin() { - return indicator.column == 0? indicator.column : indicator.column - 1; + return cdf_source_format().left_margin(); } static inline int right_margin() { - return indicator.right_margin == 0? - indicator.right_margin : indicator.right_margin - 1; + return cdf_source_format().right_margin(); } /* @@ -74,22 +83,9 @@ static inline int right_margin() { * When setting back to 0 (free), the right margin is also reset to 0. */ void -cobol_set_indicator_column( int column ) -{ - indicator.explicitly = true; - if( column == 0 ) indicator.right_margin = 0; - if( column < 0 ) { - column = -column; - indicator.right_margin = 73; - } - indicator.column = column; -} +cobol_set_indicator_column( int column ); -bool 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 include_debug() { return is_fixed_format() && debug_mode; } bool set_debug( bool tf ) { return debug_mode = tf && is_fixed_format(); } static bool nonblank( const char ch ) { return !isblank(ch); } @@ -103,7 +99,7 @@ start_of_line( char *bol, char *eol ) { static inline char * continues_at( char *bol, char *eol ) { - if( indicator.column == 0 ) return NULL; // cannot continue in free format + if( cdf_source_format().is_free() ) return NULL; // cannot continue in free format bol += left_margin(); if( *bol != '-' ) return NULL; // not a continuation line return start_of_line(++bol, eol); @@ -112,8 +108,8 @@ continues_at( char *bol, char *eol ) { // Return pointer to indicator column. Test ch if provided. // NULL means no indicator column or tested value not present. static inline char * -indicated( char *bol, char *eol, char ch = '\0' ) { - if( indicator.column == 0 && *bol != '*' ) { +indicated( char *bol, const char *eol, char ch = '\0' ) { + if( cdf_source_format().left_margin() == 0 && *bol != '*' ) { return NULL; // no indicator column in free format, except for comments } gcc_assert(bol != NULL); @@ -129,10 +125,10 @@ indicated( char *bol, char *eol, char ch = '\0' ) { static char * remove_inline_comment( char *bol, char *eol ) { - static char ends = '\0'; char *nl = std::find(bol, eol, '\n'); if( bol < nl ) { + static char ends = '\0'; std::swap(*nl, ends); char *comment = strstr(bol, "*>"); if( comment ) { @@ -197,10 +193,10 @@ maybe_add_space(const span_t& pattern, replace_t& recognized) { } if( befter[0] == blank || befter[1] == blank ) { - char *s = xasprintf( "%s%.*s%s", - befter[0], - recognized.after.size(), recognized.after.p, - befter[1] ); + const char *s = xasprintf( "%s%.*s%s", + befter[0], + recognized.after.size(), recognized.after.p, + befter[1] ); recognized.after = span_t(s, s + strlen(s)); } } @@ -255,14 +251,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 +288,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,21 +305,85 @@ 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()); } } static void +check_push_pop_directive( filespan_t& mfile ) { + char eol = '\0'; + const char *p = std::find(mfile.cur, mfile.eol, '>'); + if( ! (p < mfile.eol && p[1] == *p ) ) return; + + const char pattern[] = + ">>[[:blank:]]*(push|pop)[[:blank:]]+" + "(" + "all|" + "call-convention|" + "cobol-words|" + "define|" + "source[[:blank:]]+format|" + "turn" + ")"; + static regex re(pattern, extended_icase); + + // show contents of marked subexpressions within each match + cmatch cm; + + std::swap(*mfile.eol, eol); // see implementation for excuses + bool ok = regex_search(p, const_cast<const char *>(mfile.eol), cm, re); + std::swap(*mfile.eol, eol); + + if( ok ) { + gcc_assert(cm.size() > 1); + bool push = TOUPPER(cm[1].first[1]) == 'U'; + switch( TOUPPER(cm[2].first[0]) ) { + case 'A': // ALL + push? cdf_push() : cdf_pop(); + break; + case 'C': + switch( TOUPPER(cm[2].first[1]) ) { + case 'A': // CALL-CONVENTION + push? cdf_push_call_convention() : cdf_pop_call_convention(); + break; + case 'O': // COBOL-WORDS + push? cdf_push_current_tokens() : cdf_pop_current_tokens(); + break; + default: + gcc_unreachable(); + } + break; + case 'D': // DEFINE + push? cdf_push_dictionary() : cdf_pop_dictionary(); + break; + case 'S': // SOURCE FORMAT + push? cdf_push_source_format() : cdf_pop_source_format(); + break; + case 'T': // TURN + push? cdf_push_enabled_exceptions() : cdf_pop_enabled_exceptions(); + break; + default: + gcc_unreachable(); + } + erase_line(const_cast<char*>(cm[0].first), + const_cast<char*>(cm[0].second)); + } +} + +static void check_source_format_directive( filespan_t& mfile ) { + char eol = '\0'; const char *p = std::find(mfile.cur, mfile.eol, '>'); if( ! (p < mfile.eol && p[1] == *p ) ) return; @@ -330,7 +396,12 @@ check_source_format_directive( filespan_t& mfile ) { // show contents of marked subexpressions within each match cmatch cm; - if( regex_search(p, (const char *)mfile.eol, cm, re) ) { + + std::swap(*mfile.eol, eol); // see implementation for excuses + bool ok = regex_search(p, const_cast<const char *>(mfile.eol), cm, re); + std::swap(*mfile.eol, eol); + + if( ok ) { gcc_assert(cm.size() > 1); switch( cm[3].length() ) { case 4: @@ -343,11 +414,14 @@ check_source_format_directive( filespan_t& mfile ) { gcc_assert(cm[3].length() == 4 || cm[3].length() == 5); break; } - 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)); + + dbgmsg( "%s:%d: %s format set, on line " HOST_SIZE_T_PRINT_UNSIGNED, + __func__, __LINE__, + cdf_source_format().description(), + (fmt_size_t)mfile.lineno() ); + char *bol = cdf_source_format().is_fixed()? mfile.cur : const_cast<char*>(cm[0].first); + gcc_assert(cm[0].second <= mfile.eol); + erase_line(bol, const_cast<char*>(cm[0].second)); } } @@ -380,21 +454,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 +515,9 @@ struct replacing_term_t { bool matched, done; span_t leading_trailing, term, stmt; - replacing_term_t(const char input[]) : matched(false), done(false) { - stmt = span_t(input, input); - } + explicit replacing_term_t(const char input[]) + : matched(false), done(false), stmt(span_t(input, input)) + {} }; extern YYLTYPE yylloc; @@ -457,11 +538,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 +587,7 @@ update_yylloc( const csub_match& stmt, const csub_match& term ) { static replacing_term_t parse_replacing_term( const char *stmt, const char *estmt ) { - gcc_assert(stmt); gcc_assert(estmt); gcc_assert(stmt < estmt); + gcc_assert(stmt); gcc_assert(estmt); gcc_assert(stmt <= estmt); replacing_term_t output(stmt); static const char pattern[] = @@ -600,7 +681,8 @@ parse_replacing_term( const char *stmt, const char *estmt ) { } if( extraneous_replacing ) { update_yylloc( cm[0], cm[8] ); - yywarn("syntax error: invalid '%.*s'", cm[8].length(), cm[8].first); + cbl_message(LexReplaceE, "syntax error: invalid '%.*s'", + cm[8].length(), cm[8].first); output.matched = false; return output; } @@ -716,13 +798,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); + cbl_message(LexReplaceE, "LEX syntax error '%.*s'", (int)pair.stmt.size(), pair.stmt.p); } else { // This eliminated a compiler warning about "format-overflow" - yywarn("CDF syntax error"); + cbl_message(LexReplaceE, "LEX syntax error"); } - pair.stmt = span_t(0UL, stmt); + pair.stmt = span_t(size_t(0), stmt); pair.replace = replace_t(); } return pair; @@ -762,9 +844,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 +866,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 +905,11 @@ 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.size() ? parsed.stmt.p : "" ); int i = 0; for( const auto& replace : pairs ) { dbgmsg("%s:%d:%4d: '%s' => '%s'", __func__, __LINE__, @@ -851,7 +935,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) @@ -859,7 +943,7 @@ location_in( const filespan_t& mfile, const csub_match cm ) { gcc_assert(mfile.cur <= cm.first && cm.second <= mfile.eodata); auto nline = std::count(cm.first, cm.second, '\n'); if( nline ) { - gcc_assert(loc.first_line < nline); + gcc_assert(nline < loc.first_line); loc.first_line -= nline; auto p = static_cast<const char*>(memrchr(cm.first, '\n', cm.length())); loc.last_column = (cm.second) - p; @@ -902,14 +986,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 +1007,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 +1039,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 +1066,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 +1076,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 +1092,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 +1126,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 +1167,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 +1205,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 +1254,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--; @@ -1288,13 +1381,13 @@ lexer_input( char buf[], int max_size, FILE *input ) { for( auto p = mfile.cur; p < next; *output.pos++ = *p++ ) { static bool at_bol = false; if( at_bol ) { - auto nonblank = std::find_if( p, next, + auto nonblank_l = std::find_if( p, next, []( char ch ) { return !isblank(ch); } ); - if( nonblank + 1 < next ) { - if( *nonblank == '\r' ) nonblank++; // Windows - if( *nonblank == '\n' ) { - p = nonblank; + if( nonblank_l + 1 < next ) { + if( *nonblank_l == '\r' ) nonblank_l++; // Windows + if( *nonblank_l == '\n' ) { + p = nonblank_l; continue; } } @@ -1374,7 +1467,8 @@ 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); + cbl_message(LexPreprocessE, "preprocessor '%s/%s' not found", + getcwd(NULL, 0), filter.c_str()); return false; } preprocessor_filters.push_back( std::make_pair(xstrdup(filename), options) ); @@ -1385,22 +1479,22 @@ void cdftext::echo_input( int input, const char filename[] ) { int fd; if( -1 == (fd = dup(input)) ) { - yywarn( "could not open preprocessed file %s to echo to standard output", - filename ); + cbl_message(LexPreprocessE, "could not open preprocessed file " + "%s to echo to standard output", filename ); return; } auto mfile = map_file(fd); if( -1 == write(STDOUT_FILENO, mfile.data, mfile.size()) ) { - yywarn( "could not write preprocessed file %s to standard output", + cbl_message(LexPreprocessE, "could not write preprocessed file %s to standard output", filename ); } if( -1 == munmap(mfile.data, mfile.size()) ) { - yywarn( "could not release mapped file" ); + cbl_message(LexPreprocessE, "could not release mapped file" ); } if( -1 == close(fd) ) { - yywarn( "could not close mapped file" ); + cbl_message(LexPreprocessE, "could not close mapped file" ); } } @@ -1420,18 +1514,20 @@ cdftext::lex_open( const char filename[] ) { int output = open_output(); - // Process any files supplied by the -include comamnd-line option. + // Process any files supplied by the -include command-line option. for( auto name : included_files ) { - int input; if( -1 == (input = open(name, O_RDONLY)) ) { - yyerrorvl(1, "", "cannot open -include file %s", name); + cbl_message(LexIncludeE, "cannot open %<-include%> file %qs", name); continue; } cobol_filename(name, inode_of(input)); 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 +1549,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; @@ -1475,18 +1571,18 @@ cdftext::lex_open( const char filename[] ) { } int erc; if( -1 == (erc = execv(filter, argv.data())) ) { - yywarn("could not execute %s", filter); + cbl_message(LexPreprocessE, "could not execute %s", filter); } _exit(erc); } 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 ) { @@ -1494,7 +1590,7 @@ cdftext::lex_open( const char filename[] ) { filter, status); } } - yywarn( "applied %s", filter ); + cbl_message(LexIncludeOkN, "applied %s", filter ); } return fdopen( output, "r"); @@ -1504,13 +1600,13 @@ 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"); if( verbose_file_reader ) { - yywarn("verbose: opening %s for input", filename); + cbl_message(LexInputN, "verbose: opening %s for input", filename); } return fd; } @@ -1518,9 +1614,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 +1657,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 +1681,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,32 +1743,21 @@ cdftext::free_form_reference_format( int input ) { size_t lineno; bytespan_t line; // construct with length zero - current_line_t( char data[] ) : lineno(0), line(data, data) {} + explicit current_line_t( char data[] ) : lineno(0), line(data, data) {} } current( mfile.data ); /* - * 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++; + if( cdf_source_format().inference_pending() ) { + const char *bol = valid_sequence_area(mfile.data, mfile.eodata); + if( bol ) { + cdf_source_format().infer( bol, infer_reference_format(bol, mfile.eodata) ); } - if( valid_sequence_area(p, mfile.eodata) ) indicator.column = 7; - - dbgmsg("%s:%d: %s format detected", __func__, __LINE__, - indicator.column == 7? "FIXED" : "FREE"); } while( mfile.next_line() ) { + check_push_pop_directive(mfile); check_source_format_directive(mfile); remove_inline_comment(mfile.cur, mfile.eol); @@ -1745,15 +1878,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 +1905,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__, (fmt_size_t)mfile.lineno(), copybook.source(), copybook.current()->fd); copy.in = copybook.current()->fd; copy.mfile = free_form_reference_format( copy.in ); @@ -1809,31 +1942,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 +1955,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 +1971,30 @@ cdftext::segment_line( filespan_t& mfile ) { return output; } + /* + * If the replacement changes the number of lines in the replaced text, we + * need to reset the line number, because the next statement is on a + * different line in the manipulated text than in the original. Before each + * replacement, set the original line number. After each replacement, set + * the line number after the elided text on the next line. + */ for( const replace_t& segment : pending ) { gcc_assert(mfile.cur <= segment.before.p); gcc_assert(segment.before.pend <= mfile.eodata); + struct { unsigned long ante, post; } lineno = { + gb4(mfile.lineno()), gb4(mfile.lineno() + segment.after.nlines()) + }; + const char *directive = lineno.ante == lineno.post? + nullptr : xasprintf("\n#line %lu \"%s\"\n", + lineno.ante, cobol_filename()); + + if( directive ) + output.push_back( span_t(strlen(directive), directive) ); output.push_back( span_t(mfile.cur, segment.before.p) ); output.push_back( span_t(segment.after.p, segment.after.pend ) ); + if( directive ) + output.push_back( span_t(strlen(directive), directive) ); mfile.cur = const_cast<char*>(segment.before.pend); } @@ -1877,5 +2010,3 @@ cdftext::segment_line( filespan_t& mfile ) { return output; } - -//////// End of the cdf_text.h file diff --git a/gcc/cobol/lexio.h b/gcc/cobol/lexio.h index cf7f53a..ba4ef0a 100644 --- a/gcc/cobol/lexio.h +++ b/gcc/cobol/lexio.h @@ -43,7 +43,6 @@ #define SPACE ' ' bool lexer_echo(); - bool is_reference_format(); static inline bool isquote( char ch ) { @@ -70,7 +69,9 @@ erase_source( char *src, char *esrc ) { struct bytespan_t { char *data, *eodata; - bytespan_t( char *data = NULL, char *eodata = NULL ) + bytespan_t() : data( nullptr), eodata(nullptr) {} + + bytespan_t( char *data, char *eodata ) : data(data), eodata(eodata) { if( eodata < data ) { @@ -111,19 +112,7 @@ struct bytespan_t { } }; -/* Location type. Borrowed from parse.h as generated by Bison. */ -#if ! defined YYLTYPE && ! defined YYLTYPE_IS_DECLARED -typedef struct YYLTYPE YYLTYPE; -struct YYLTYPE -{ - int first_line; - int first_column; - int last_line; - int last_column; -}; -# define YYLTYPE_IS_DECLARED 1 -# define YYLTYPE_IS_TRIVIAL 1 -#endif +// YYLTYPE supplied by cbldiag.h. Borrowed from parse.h as generated by Bison. struct filespan_t : public bytespan_t { char *cur, *eol, *quote; @@ -137,7 +126,7 @@ struct filespan_t : public bytespan_t { {} filespan_t(void *p, size_t len) : bytespan_t( static_cast<char*>(p), static_cast<char*>(p) + len ) - , cur(data), eol(data), quote(NULL), iline(0), line_quote72(0) + , cur(data), eol(data), quote(NULL), iline(0), icol(0), line_quote72(0) {} size_t lineno() const { return iline; } @@ -237,6 +226,7 @@ struct span_t { span_t( const char *data, const char *eodata ) : p(data), pend(eodata) { verify(); } + // cppcheck-suppress operatorEqRetRefThis span_t& operator=( const csub_match& cm ) { p = cm.first; pend = cm.second; @@ -245,6 +235,8 @@ struct span_t { int size() const { return pend - p; } + size_t nlines() const { return p && pend? std::count(p, pend, '\n') : 0; } + span_t dup() const { auto output = new char[size() + 1]; auto eout = std::copy(p, pend, output); @@ -252,15 +244,22 @@ struct span_t { return span_t(output, eout); } const char * has_nul() const { - auto p = std::find(this->p, pend, '\0'); - return p != pend? p : NULL; + auto p_l = std::find(this->p, pend, '\0'); + return p_l != pend? p_l : NULL; + } + + bool at_eol() const { + return p < pend && '\n' == pend[-1]; + } + const char * optional_eol() const { + return at_eol() ? "" : "\n"; } }; struct replace_t { struct span_t before, after; - replace_t( span_t before = span_t(), - span_t after = span_t() ) + replace_t() : before(span_t()), after(span_t()) {} + replace_t( span_t before, span_t after ) : before(before), after(after) {} replace_t& reset() { diff --git a/gcc/cobol/messages.cc b/gcc/cobol/messages.cc new file mode 100644 index 0000000..423b53a --- /dev/null +++ b/gcc/cobol/messages.cc @@ -0,0 +1,388 @@ +/* + * 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. + */ + +/* + * Define a table of diagnositic messages, each uniquely identified and + * grouped into dialects. The user can select on the command line which + * ones are in effect. + */ + +#include <cobol-system.h> +#include <coretypes.h> +#include <tree.h> +#undef yy_flex_debug + +#include <langinfo.h> + +#include <coretypes.h> +#include <version.h> +#include <demangle.h> +#include <intl.h> +#include <backtrace.h> +#include <diagnostic.h> +#include <opts.h> +#include "util.h" + +#include "cbldiag.h" +#include "cdfval.h" +#include "lexio.h" + +#include "../../libgcobol/ec.h" +#include "../../libgcobol/common-defs.h" +#include "symbols.h" +#include "inspect.h" +#include "../../libgcobol/io.h" +#include "genapi.h" +#include "genutil.h" +#include "../../libgcobol/charmaps.h" + + + +/* + * As of now, every diagnositc has one id, one message, one kind, and is + * associated with "one" dialect. The dialect could be ORed. If it is, that + * means among the dialects it belongs to, it is always of the same kind. + * + * The diagnositic mask in force during compilation may include/exclude + * features based on their associated dialect and/or by id. It may stipulate + * that a warning is treated as an error, too, but that's up the diagnostic + * framework. If a feature requires a dialect and is not specifically enabled, + * gcobol emits of message of the associated kind, and names the dialect + * required. + */ +struct cbl_diag_t { + cbl_diag_id_t id; + cbl_name_t option; + diagnostics::kind kind; + cbl_dialect_t dialect; + + explicit cbl_diag_t( cbl_diag_id_t id ) + : id(id), option(""), kind(diagnostics::kind::ignored), dialect(dialect_gcc_e) + {} + + cbl_diag_t( cbl_diag_id_t id, + const char option[], + diagnostics::kind kind, + cbl_dialect_t dialect = dialect_iso_e ) + : id(id), option(""), kind(kind), dialect(dialect) + { + gcc_assert(strlen(option) < sizeof(this->option)); + strcpy(this->option, option); + } + + bool operator<( const cbl_diag_t& that ) const { + return id < that.id; + } +}; + +/* + * Initially, errors and warnings are set per the default, dialect gcc. If the + * user chooses dialect iso, all dialect-enabled features are turned into + * errors. If the user selects a more generous dialect, features associated + * with it are set to be ignored. + * + * Individual features may also be suppressed, and all warnings may be elevated + * to errors. + */ +const static auto dialect_mf_gnu = cbl_dialect_t(dialect_mf_e | dialect_gnu_e); +const static auto dialect_ibm_mf_gnu = cbl_dialect_t(dialect_ibm_e | + dialect_mf_e | + dialect_gnu_e); + +std::set<cbl_diag_t> cbl_diagnostics { + { CdfNotFoundW, "-Wcdf-name-not-found", diagnostics::kind::warning }, + { CdfParameterW, "-Wcdf-invalid-parameter", diagnostics::kind::warning }, + + { EcUnknownW, "-Wec-unknown", diagnostics::kind::warning }, + + { IbmEjectE, "-Wcobol-eject", diagnostics::kind::error, dialect_ibm_e }, + { IbmLengthOf, "-Wlength-of", diagnostics::kind::error, dialect_ibm_mf_gnu }, + { IbmEqualAssignE, "-Wequal-assign", diagnostics::kind::error, dialect_ibm_e }, + { IbmProcedurePointer, "-Wprocedure-pointer", diagnostics::kind::error, dialect_ibm_mf_gnu }, + { IbmSectionNegE, "-Wsegment-negative", diagnostics::kind::error, dialect_ibm_e }, + { IbmSectionRangeE, "-Wsegment-error", diagnostics::kind::error, dialect_ibm_e }, + { IbmSectionSegmentW, "-Wsegment", diagnostics::kind::warning, dialect_ibm_e }, + { IbmStopNumber, "-Wstop-number", diagnostics::kind::error, dialect_ibm_e }, + { IbmVolatileE, "-Wcobol-volatile", diagnostics::kind::error, dialect_ibm_e }, + { IbmVolatileW, "-Wcobol-volatile", diagnostics::kind::warning, dialect_ibm_e }, + + // RESUME not supported by IBM + { IsoResume, "-Wcobol-resume", diagnostics::kind::error, dialect_ibm_e }, + + { MfBinaryLongLong, "-Wbinary-long-long", diagnostics::kind::error, dialect_mf_gnu }, + { MfCallGiving, "-Wcall-giving", diagnostics::kind::error, dialect_mf_gnu }, + { MfCdfDollar, "-Wcdf-dollar", diagnostics::kind::error, dialect_mf_gnu }, + { MfComp6, "-Wcomp-6", diagnostics::kind::error, dialect_mf_gnu }, + { MfCompX, "-Wcomp-x", diagnostics::kind::error, dialect_mf_gnu }, + { MfLevel_1_Occurs, "Wlevel-1-occurs", diagnostics::kind::error, dialect_mf_gnu }, + { MfLevel78, "-Wlevel-78", diagnostics::kind::error, dialect_mf_gnu }, + { MfMovePointer, "-Wmove-pointer", diagnostics::kind::error, dialect_mf_gnu }, + { MfReturningNum, "-Wreturning-number", diagnostics::kind::error, dialect_mf_gnu }, + { MfUsageTypename, "-Wusage-typename", diagnostics::kind::error, dialect_mf_gnu }, + { MfTrailing, "-Winspect-trailing", diagnostics::kind::error, dialect_mf_gnu }, + + { LexIncludeE, "-Winclude-file-not-found", diagnostics::kind::error }, + { LexIncludeOkN, "-Winclude-file-found", diagnostics::kind::note }, + { LexIndicatorE, "-Wstray-indicator", diagnostics::kind::error }, + { LexInputN, "-Wcopybook-found", diagnostics::kind::note }, + { LexLineE, "-Wbad-line-directive", diagnostics::kind::error }, + { LexPreprocessE, "-Wpreprocessor-error", diagnostics::kind::error }, + { LexReplaceE, "-Wreplace-error", diagnostics::kind::error }, + // mf and gnu do not require whitespace after relational operators + { LexSeparatorE, "-Woperator-space", diagnostics::kind::error, dialect_mf_gnu }, + + { Par78CdfDefinedW, "-Wlevel-78-defined", diagnostics::kind::warning }, + { ParIconvE, "-Wiconv-error", diagnostics::kind::note }, + { ParInfoI, "-Wentry-convention", diagnostics::kind::note }, + { ParLangInfoW, "-Wnllanginfo-error", diagnostics::kind::warning }, + { ParLiteral2W, "-Wliteral-concat", diagnostics::kind::warning }, + { ParLocaleW, "-Wlocale-error", diagnostics::kind::warning }, + { ParNoCorrespondingW, "-Wmove-corresponding", diagnostics::kind::warning }, + { ParNumstrW, "-Wbad-numeric", diagnostics::kind::warning }, + { ParUnresolvedProcE, "-Wprocedure-not-found", diagnostics::kind::error }, + + // unimplmeneted syntax warnings + { SynApplyCommit, "-Wapply-commit", diagnostics::kind::warning }, + { SynFileCodeSet, "-Wfile-code-set", diagnostics::kind::warning }, + { SynHighOrderBit, "-Whigh-order-bit", diagnostics::kind::warning }, + { SynRecordingMode, "-Wrecording-mode", diagnostics::kind::warning }, + { SynSetLocaleTo, "-Wset-locale-to", diagnostics::kind::warning }, + { SynSetToLocale, "-Wset-to-locale", diagnostics::kind::warning }, + +}; + +static struct set_verify { + set_verify() { + gcc_assert(cbl_diagnostics.size() == DiagDiagDiag); + auto p = std::find_if(cbl_diagnostics.begin(), cbl_diagnostics.end(), + []( const auto& diag ) { + return '?' == cbl_dialect_str(diag.dialect)[0]; + } ); + if( p != cbl_diagnostics.end() ) { + fprintf(stderr, "unregconized dialect '%04x (~%04x)'", p->dialect, ~p->dialect); + } + gcc_assert( std::none_of(cbl_diagnostics.begin(), cbl_diagnostics.end(), + []( const auto& diag ) { + return '?' == cbl_dialect_str(diag.dialect)[0]; + } ) ); + } +} verify_consistent_message_count; + +static inline diagnostics::kind +kind_of( cbl_diag_id_t id ) { + auto diag = cbl_diagnostics.find(cbl_diag_t(id)); + if( diag != cbl_diagnostics.end() ) { + return diag->kind; + } + return diagnostics::kind::ice; +} + +diagnostics::kind +cbl_diagnostic_kind( cbl_diag_id_t id ) { + return kind_of(id); +} + +bool +cbl_diagnostic_kind( cbl_diag_id_t id, diagnostics::kind kind ) { + auto p = cbl_diagnostics.find( cbl_diag_t{id} ); + if( p != cbl_diagnostics.end() ) { + auto diag(*p); + diag.kind = kind; + cbl_diagnostics.erase(p); + return cbl_diagnostics.insert(diag).second; + } + return false; +} + +bool +cbl_diagnostic_kind( cbl_dialect_t dialect, diagnostics::kind kind ) { + bool ok = true; + for( auto diag : cbl_diagnostics ) { + if( diag.dialect == dialect ) { + if( ! cbl_diagnostic_kind(diag.id, kind) ) ok = false; + } + } + return ok; +} + +void +cobol_warning( cbl_diag_id_t id, int yn, bool warning_as_error ) { + gcc_assert( 0 <= yn && yn <= 1 ); + + diagnostics::kind kind = yn? + diagnostics::kind::warning : diagnostics::kind::ignored; + + if( warning_as_error ) { + kind = diagnostics::kind::error; + } + + cbl_diagnostic_kind(id, kind); +} + +static inline const char * +option_of( cbl_diag_id_t id ) { + auto diag = cbl_diagnostics.find(cbl_diag_t(id)); + if( diag != cbl_diagnostics.end() && diag->option[0] ) { + return diag->option; + } + return nullptr; +} + +const char * +cbl_diagnostic_option( cbl_diag_id_t id ) { + return option_of(id); +} + +/* + * This is the general message looker-upper. It determines whether the + * diagnositic is in force, at what level, and the message text, and invokes + * the framework. + */ +extern int yychar; +extern YYLTYPE yylloc; + +static const diagnostics::option_id option_zero; + +location_t current_token_location(); +location_t current_token_location(const location_t& loc); + +bool +cbl_message( cbl_diag_id_t id, const char gmsgid[], ... ) { + auto_diagnostic_group d; + const char *option; + char *msg = nullptr; + + diagnostics::kind kind = kind_of(id); + if( kind == diagnostics::kind::ignored ) return false; + + if( (option = option_of(id)) != nullptr ) { + msg = xasprintf("%s [%s]", gmsgid, option); + gmsgid = msg; + } + + va_list ap; + + va_start (ap, gmsgid); + auto ret = emit_diagnostic_valist( kind, current_token_location(), + option_zero, gmsgid, &ap ); + va_end (ap); + free(msg); + + return ret; +} + +bool cbl_message( cbl_loc_t loc, cbl_diag_id_t id, const char gmsgid[], ... ) { + class temp_loc_t { // copied from util.cc + location_t orig; + public: + temp_loc_t() : orig(current_token_location()) { + if( yychar < 3 ) return; + + gcc_location_set(yylloc); // use lookahead location + } + explicit temp_loc_t( const YYLTYPE& loc) : orig(current_token_location()) { + gcc_location_set(loc); + } + explicit temp_loc_t( const YDFLTYPE& loc) : orig(current_token_location()) { + gcc_location_set(loc); + } + ~temp_loc_t() { + if( orig != current_token_location() ) { + current_token_location(orig); + } + } + }; + + auto_diagnostic_group d; + const char *option; + char *msg = nullptr; + + diagnostics::kind kind = kind_of(id); + if( kind == diagnostics::kind::ignored ) return false; + + if( (option = option_of(id)) != nullptr ) { + msg = xasprintf("%s [%s]", gmsgid, option); + gmsgid = msg; + } + + temp_loc_t looker(loc); + va_list ap; + + va_start (ap, gmsgid); + rich_location richloc (line_table, current_token_location()); + auto ret = emit_diagnostic_valist( kind, + current_token_location(), + option_zero, gmsgid, &ap ); + va_end (ap); + free(msg); + + return ret; +} + +/* + * Verify the dialect associated with the id (and thus term) is covered by the + * dialects currently in effect. If not, issue a standard message of the kind + * defined by the id. Possible combinations: + * dialect required: ok, dialect matches feature dialect + * dialect prohibits not_ok, dialect matches feature ~dialect + * + * If ok is false, then a match means the dialect prohibits the feature. + */ +bool +dialect_ok( const cbl_loc_t& loc, cbl_diag_id_t id, const char term[], bool ok ) { + auto diag = cbl_diagnostics.find(cbl_diag_t(id)); + + const char *verb = "requires"; + + if( diag == cbl_diagnostics.end() ) { + gcc_unreachable(); + } + + if( diag->kind == diagnostics::kind::ignored ) return true; + + if( dialect_has(diag->dialect) ) { + if( ok ) { + return true; + } else { + verb = "prohibits"; + } + } else { + if( !ok ) return true; // current dialect correctly does not match the feature + } + + cbl_message(loc, id, "%qs %s %<-dialect %s%>", + term, verb, cbl_dialect_str(diag->dialect)); + return false; +} + + + + + diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index c45dc33..ad292b9 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -28,10 +28,13 @@ * 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" #include "../../libgcobol/io.h" #include "../../libgcobol/ec.h" + #include "tree.h" #pragma GCC diagnostic ignored "-Wmissing-field-initializers" @@ -42,23 +45,62 @@ }; enum accept_func_t { + accept_e, accept_done_e, accept_command_line_e, accept_envar_e, }; + struct coll_alphanat_t { + const char *alpha, *national; + }; + + struct label_pair_t { + cbl_label_t *from, *to; + }; + +class locale_tgt_t { + char user_system_default; + std::vector<int> categories; + public: + locale_tgt_t() : user_system_default('\0') {} + locale_tgt_t( int category ) + : user_system_default('\0') + , categories(1, category) + {} + locale_tgt_t operator=( int ch ) { + assert(categories.empty()); + switch(ch) { + case 'S': case 'U': + user_system_default = ch; + return *this; + } + gcc_unreachable(); + } + locale_tgt_t push_back( int token ) { + categories.push_back(token); + return *this; + } + + bool is_default() const { return 0 < user_system_default; } + char default_of() const { + assert(categories.empty()); + return user_system_default; + } + const std::vector<int>& lc_categories() const { return categories; } +}; + class literal_t { size_t isym; public: + cbl_encoding_t encoding; char prefix[3]; size_t len; char *data; bool empty() const { return data == NULL; } size_t isymbol() const { return isym; } - const char * symbol_name() const { - return isym? cbl_field_of(symbol_at(isym))->name : ""; - } + const char * symbol_name() const; literal_t& set( size_t len, char *data, const char prefix[] ) { @@ -67,17 +109,8 @@ return *this; } - literal_t& - set( const cbl_field_t * field ) { - assert(field->has_attr(constant_e)); - assert(is_literal(field)); - - set_prefix( "", 0 ); - set_data( field->data.capacity, - const_cast<char*>(field->data.initial), - field_index(field) ); - return *this; - } + literal_t& set( const cbl_field_t * field ); + literal_t& set_data( size_t len, char *data, size_t isym = 0 ) { this->isym = isym; @@ -90,13 +123,8 @@ } return *this; } - literal_t& - set_prefix( const char *input, size_t len ) { - assert(len < sizeof(prefix)); - std::fill(prefix, prefix + sizeof(prefix), '\0'); - std::transform(input, input + len, prefix, toupper); - return *this; - } + literal_t& set_prefix( const char *input, size_t len ); + bool compatible_prefix( const literal_t& that ) const { if( prefix[0] != that.prefix[0] ) { @@ -185,14 +213,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()) @@ -205,7 +233,7 @@ static data_category_t data_category_of( const cbl_refer_t& refer ); - static _Float128 + static REAL_VALUE_TYPE numstr2i( const char input[], radix_t radix ); struct cbl_field_t; @@ -239,7 +267,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 ) { @@ -277,8 +305,14 @@ } %{ +#include "config.h" #include <fstream> // Before cobol-system because it uses poisoned functions #include "cobol-system.h" +#include "coretypes.h" +#include "tree.h" +#undef cobol_dialect +#undef cobol_exceptions +#undef yy_flex_debug #include "cdfval.h" #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" @@ -290,6 +324,7 @@ #include "genapi.h" #include "../../libgcobol/exceptl.h" #include "exceptg.h" +#include "../../libgcobol/charmaps.h" #include "parse_ante.h" %} @@ -323,16 +358,16 @@ NUMED "NUMERIC-EDITED picture" NUMED_CR "NUMERIC-EDITED CR picture" NUMED_DB "NUMERIC-EDITED DB picture" -%token <number> NINEDOT NINES NINEV PIC_P -%token <string> SPACES +%token <number> NINEDOT NINES NINEV PIC_P ONES +%token <string> SPACES EQ "EQUAL" %token <literal> LITERAL %token <number> END EOP %token <string> FILENAME %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 @@ -340,7 +375,7 @@ %token <string> SECTION %token <number> STANDARD_ALPHABET "STANDARD ALPHABET" %token <string> SWITCH -%token <string> UPSI +%token <string> UPSI %token <number> ZERO /* environment names */ @@ -354,6 +389,7 @@ %token <number> MIGHT_BE "IS or IS NOT" FUNCTION_UDF "UDF name" FUNCTION_UDF_0 "UDF" + DEFAULT %token <string> DATE_FMT "date format" TIME_FMT "time format" @@ -366,7 +402,7 @@ LSUB "(" PARAMETER_kw "PARAMETER" OVERRIDE READY RESET - RSUB ")" + RSUB")" SERVICE_RELOAD "SERVICE RELOAD" STAR_CBL "*CBL" SUBSCRIPT SUPPRESS TITLE TRACE USE @@ -376,7 +412,10 @@ CDF_EVALUATE ">>EVALUATE" CDF_WHEN ">>WHEN" CDF_END_EVALUATE ">>END-EVALUATE" + CALL_CONVENTION ">>CALL-CONVENTION" CALL_COBOL "CALL" CALL_VERBATIM "CALL (as C)" + CDF_PUSH ">>PUSH" CDF_POP ">>POP" + SOURCE_FORMAT ">>SOURCE FORMAT" IF THEN ELSE SENTENCE @@ -390,7 +429,10 @@ STRING_kw "STRING" STOP SUBTRACT START UNSTRING WRITE WHEN - ABS ACCESS ACOS ACTUAL ADVANCING AFTER ALL + ARGUMENT_NUMBER ARGUMENT_VALUE + ENVIRONMENT_NAME ENVIRONMENT_VALUE + + ABS ACCESS ACOS ACTUAL ADVANCING AFTER ALL ALLOCATE ALPHABET ALPHABETIC ALPHABETIC_LOWER "ALPHABETIC-LOWER" ALPHABETIC_UPPER "ALPHABETIC-UPPER" @@ -402,7 +444,7 @@ BASED BASECONVERT BEFORE BINARY BIT BIT_OF "BIT-OF" BIT_TO_CHAR "BIT-TO-CHAR" - BLANK BLOCK + BLANK BLOCK_kw BOOLEAN_OF_INTEGER "BOOLEAN-OF-INTEGER" BOTTOM BY BYTE BYTE_LENGTH "BYTE-LENGTH" @@ -410,7 +452,7 @@ CF CH CHANGED CHAR CHAR_NATIONAL "CHAR-NATIONAL" CHARACTER CHARACTERS CHECKING CLASS - COBOL CODE CODESET COLLATING + COBOL CODE CODESET "CODE-SET" COLLATING COLUMN COMBINED_DATETIME "COMBINED-DATETIME" COMMA COMMAND_LINE "COMMAND-LINE" COMMAND_LINE_COUNT "COMMAND-LINE-COUNT" @@ -429,14 +471,14 @@ DAY_OF_WEEK "DAY-OF-WEEK" DAY_TO_YYYYDDD "DAY-TO-YYYYDDD" DBCS DE DEBUGGING DECIMAL_POINT - DECLARATIVES DEFAULT DELIMITED DELIMITER DEPENDING + DECLARATIVES DELIMITED DELIMITER DEPENDING DESCENDING DETAIL DIRECT DIRECT_ACCESS "DIRECT-ACCESS" DOWN DUPLICATES DYNAMIC - E EBCDIC EC EGCS ENTRY ENVIRONMENT EQUAL EVERY - EXAMINE EXHIBIT EXP EXP10 EXTEND EXTERNAL + E EBCDIC EC EGCS ENCODING ENTRY ENVIRONMENT + EVERY EXAMINE EXHIBIT EXP EXP10 EXTEND EXTERNAL EXCEPTION_FILE "EXCEPTION-FILE" EXCEPTION_FILE_N "EXCEPTION-FILE-N" @@ -478,7 +520,7 @@ INTEGER_OF_DAY "INTEGER-OF-DAY" INTEGER_OF_FORMATTED_DATE "INTEGER-OF-FORMATTED-DATE" INTEGER_PART "INTEGER-PART" - INTO INTRINSIC INVOKE IO IO_CONTROL "IO-CONTROL" + INTO INTRINSIC INVOKE IO "I-O" IO_CONTROL "I-O-CONTROL" IS ISNT "IS NOT" KANJI KEY @@ -523,7 +565,7 @@ PAGE_COUNTER "PAGE-COUNTER" PF PH PI PIC PICTURE PLUS PRESENT_VALUE PRINT_SWITCH - PROCEDURE PROCEDURES PROCEED PROCESS + PROCEDURE PROCEDURES PROCEED PROCESS PROCESSING PROGRAM_ID "PROGRAM-ID" PROGRAM_kw "Program" PROPERTY PROTOTYPE PSEUDOTEXT @@ -533,7 +575,7 @@ RD RECORD RECORDING RECORDS RECURSIVE REDEFINES REEL REFERENCE RELATIVE REM REMAINDER REMARKS REMOVAL RENAMES REPLACE REPLACING REPORT REPORTING REPORTS - REPOSITORY RERUN RESERVE RESTRICTED RESUME + REPOSITORY RERUN RESERVE RESTRICTED RESUME RETRY REVERSE REVERSED REWIND RF RH RIGHT ROUNDED RUN SAME SCREEN SD @@ -554,7 +596,7 @@ STATUS STRONG SUBSTITUTE SUM SYMBOL SYMBOLIC SYNCHRONIZED - TALLY TALLYING TAN TERMINATE TEST + TALLYING TAN TERMINATE TEST TEST_DATE_YYYYMMDD "TEST-DATE-YYYYMMDD" TEST_DAY_YYYYDDD "TEST-DAY-YYYYDDD" TEST_FORMATTED_DATETIME "TEST-FORMATTED-DATETIME" @@ -564,17 +606,16 @@ 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 + VALIDATING VALUE VARIANCE VARYING VOLATILE WHEN_COMPILED WITH WORKING_STORAGE - XML XMLGENERATE XMLPARSE YEAR_TO_YYYY YYYYDDD YYYYMMDD /* unused Context Words */ @@ -607,7 +648,7 @@ NONE NORMAL NUMBERS PREFIXED PREVIOUS PROHIBITED RELATION REQUIRED REVERSE_VIDEO ROUNDING - SECONDS SECURE SHORT SIGNED + SECONDS SECURE SHORT SIGNED_kw STANDARD_BINARY "STANDARD-BINARY" STANDARD_DECIMAL "STANDARD-DECIMAL" STATEMENT STEP STRUCTURE @@ -615,9 +656,11 @@ TOWARD_LESSER "TOWARD-LESSER" TRUNCATION UCS_4 "UCS-4" - UNDERLINE UNSIGNED + UNDERLINE UNSIGNED_kw UTF_16 "UTF-16" UTF_8 "UTF-8" + XMLGENERATE "XML GENERATE" + XMLPARSE "XML PARSE" ADDRESS END_ACCEPT "END-ACCEPT" @@ -639,6 +682,7 @@ END_SUBTRACT "END-SUBTRACT" END_UNSTRING "END-UNSTRING" END_WRITE "END-WRITE" + END_XML "END-XML" END_IF "END-IF" /* end tokens without semantic value */ @@ -649,15 +693,17 @@ %type <number> sentence statements statement %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 <number> test_before usage_clause1 might_be alphanational +%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 -%type <string> numed collating_sequence context_word ctx_name locale_spec +%type <string> numed context_word ctx_name locale_spec +%type <char_class_locales> char_class_locales coll_alphanats +%type <collating_name> coll_alphanat %type <literal> namestr alphabet_lit program_as repo_as %type <field> perform_cond kind_of_name %type <refer> alloc_ret @@ -683,7 +729,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 @@ -692,6 +738,10 @@ relative_key_clause reserve_clause sharing_clause %type <file> filename read_body write_body delete_body +%type <label> delete_file_body +%type <error> delete_error delete_except delete_excepts + +%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 @@ -705,7 +755,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 @@ -722,7 +772,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 @@ -765,6 +815,7 @@ %type <error> on_overflow on_overflows %type <error> arith_err arith_errs %type <error> accept_except accept_excepts call_except call_excepts + %type <compute_body_t> compute_body %type <refer> ffi_name set_operand set_tgt scalar_arg unstring_src @@ -783,15 +834,24 @@ %type <error_clauses> io_invalids read_eofs write_eops %type <boolean> io_invalid read_eof write_eop global is_global anycase backward + end_display + exh_changed exh_named + override %type <number> mistake globally first_last %type <io_mode> io_mode +%type <label_pair> xmlprocs +%type <error> xmlexcept xmlexcepts +%type <field> xmlencoding xmlvalidating +%type <number> xmlreturning +%type <label> xmlparse_body + %type <labels> labels %type <label> label_1 section_name %type <switches> upsi_entry -%type <special> acceptable disp_target +%type <special> acceptable disp_upon %type <display> disp_body %type <false_domain> domains domain @@ -817,24 +877,38 @@ %type <opt_init_sects> opt_init_sects %type <opt_init_sect> opt_init_sect %type <number> opt_init_value +%type <number> locale_current loc_category user_default +%type <string> locale_name +%type <token_list> loc_categories locale_tgt %type <opt_round> rounded round_between rounded_type rounded_mode %type <opt_arith> opt_arith_type %type <module_type> module_type +%type <nameloc> repo_func_name +%type <namelocs> repo_func_names +%type <codeset> codeset_name +%type <locale_phrase> locale_phrase + %union { bool boolean; int number; char *string; - _Float128 float128; // Hope springs eternal: 28 Mar 2023 + REAL_VALUE_TYPE float128; literal_t literal; cbl_field_attr_t field_attr; ec_type_t ec_type; ec_list_t* ec_list; + cbl_nameloc_t *nameloc; + cbl_namelocs_t *namelocs; declarative_list_t* dcl_list_t; isym_list_t* isym_list; struct { radix_t radix; char *string; } numstr; - struct { int token; literal_t name; } prog_end; + struct { YYLTYPE loc; int token; literal_t name; } prog_end; struct { int token; special_name_t id; } special_type; + struct { char locale_type; const char * name; } locale_phrase; + coll_alphanat_t char_class_locales; + struct collating_name_t { int token; const char *name; } collating_name; + struct { size_t isym; cbl_encoding_t encoding; } codeset; struct { cbl_field_type_t type; uint32_t capacity; bool signable; } computational; struct cbl_special_name_t *special; @@ -846,7 +920,7 @@ struct { cbl_file_t *file; file_status_t handled; } file_op; struct cbl_label_t *label; struct { cbl_label_t *label; int token; } exception; - struct cbl_field_data_t *field_data; + struct { cbl_encoding_t encoding; cbl_field_data_t *data; } field_data; struct cbl_field_t *field; struct { bool tf; cbl_field_t *field; } bool_field; struct { int token; cbl_field_t *cond; } cond_field; @@ -870,9 +944,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; @@ -882,12 +956,14 @@ struct { cbl_refer_t *input, *delimiter; } delimited_1; struct { cbl_refer_t *from, *len; } refmod_parts; struct refer_collection_t *delimiteds; + struct { cbl_label_t *on_error, *not_error; } error; + label_pair_t label_pair; struct { unsigned int nclause; bool tf; } error_clauses; struct refer_pair_t { cbl_refer_t *first, *second; } refer2; struct { refer_collection_t *inputs; refer_pair_t into; } str_body; - struct { accept_func_t func; cbl_refer_t *into, *from; } accept_func; + struct { accept_func_t func; cbl_refer_t *into, *from; special_name_t special;} accept_func; struct unstring_into_t *uns_into; struct unstring_tgt_list_t *uns_tgts; struct unstring_tgt_t *uns_tgt; @@ -915,6 +991,7 @@ substitution_t substitution; substitutions_t *substitutions; struct { bool is_locale; cbl_refer_t *arg2; } numval_locale_t; + locale_tgt_t *token_list; cbl_options_t::arith_t opt_arith; cbl_round_t opt_round; @@ -924,7 +1001,10 @@ } %printer { fprintf(yyo, "clauses: 0x%04x", $$); } data_clauses -%printer { fprintf(yyo, "%s %s", refer_type_str($$), $$? $$->name() : "<none>"); } <refer> +%printer { fprintf(yyo, "%s %s %s", + refer_type_str($$), + $$? $$->name() : "<none>", + $$ && $$->field? $$->field->codeset.name() : "<none>"); } <refer> %printer { fprintf(yyo, "%s", $$->field? name_of($$->field) : "[omitted]"); } alloc_ret %printer { fprintf(yyo, "%s %s '%s' (%s)", $$? cbl_field_type_str($$->type) : "<%empty>", @@ -938,18 +1018,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($$); @@ -961,9 +1043,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 @@ -987,14 +1069,17 @@ %right IF THEN ELSE SENTENCE ACCEPT ADD ALTER CALL CANCEL CLOSE COMPUTE CONTINUE - DELETE DISPLAY DIVIDE EVALUATE END EOP EXIT FILLER_kw + DELETE DISPLAY DIVIDE + EVALUATE END EOP EXIT + FILLER_kw GOBACK GOTO INITIALIZE INSPECT - MERGE MOVE MULTIPLY OPEN OVERFLOW 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 UNSTRING WRITE WHEN INVALID + XMLGENERATE XMLPARSE %left ABS ACCESS ACOS ACTUAL ADVANCING AFP_5A AFTER ALL ALLOCATE @@ -1003,12 +1088,12 @@ ALPHANUMERIC ALPHANUMERIC_EDITED ALPHED ALSO ALTERNATE ANNUITY ANUM ANY ANYCASE APPLY ARE - AREA AREAS AS + AREA AREAS AS ATTRIBUTES ASCENDING ACTIVATING ASIN ASSIGN AT ATAN BACKWARD BASED BASECONVERT BEFORE BINARY BIT BIT_OF BIT_TO_CHAR - BLANK BLOCK + BLANK BLOCK_kw BOOLEAN_OF_INTEGER BOTTOM BY BYTE BYTE_LENGTH @@ -1044,7 +1129,8 @@ DOWN DUPLICATES DYNAMIC - E EBCDIC EC EGCS ENTRY ENVIRONMENT EQUAL ERROR EVERY + E EBCDIC EC EGCS ELEMENT + ENTRY ENVIRONMENT ERROR EVERY EXAMINE EXCEPTION EXHIBIT EXP EXP10 EXTEND EXTERNAL EXCEPTION_FILE @@ -1115,12 +1201,13 @@ MIGHT_BE MINN MULTIPLE MOD MODE MODULE_NAME - NAMED NAT NATIONAL + NAMED NAMESPACE NAMESPACE_PREFIX "NAMESPACE-PREFIX" + NAT NATIONAL NATIONAL_EDITED NATIONAL_OF NATIVE NEGATIVE NESTED NEXT NINEDOT NINES NINEV NO NOTE NO_CONDITION - NULLS NULLPTR NUMBER + NONNUMERIC NULLS NULLPTR NUMBER NUME NUMED NUMED_CR NUMED_DB NUMERIC NUMERIC_EDITED NUMSTR NUMVAL NUMVAL_C @@ -1168,7 +1255,7 @@ LITERAL SUBSTITUTE SUM SWITCH SYMBOL SYMBOLIC SYNCHRONIZED SYSIN SYSIPT SYSLST SYSOUT SYSPCH SYSPUNCH - TALLY TALLYING TAN TERMINATE TEST + TALLYING TAN TERMINATE TEST TEST_DATE_YYYYMMDD TEST_DAY_YYYYDDD TEST_FORMATTED_DATETIME @@ -1188,7 +1275,7 @@ VALUE VARIANCE VARYING VOLATILE WHEN_COMPILED WITH WORKING_STORAGE - XML XMLGENERATE XMLPARSE + XML_DECLARATION "XML-DECLARATION" YEAR_TO_YYYY YYYYDDD YYYYMMDD ZERO @@ -1222,7 +1309,7 @@ NONE NORMAL NUMBERS PREFIXED PREVIOUS PROHIBITED RELATION REQUIRED REVERSE_VIDEO ROUNDING - SECONDS SECURE SHORT SIGNED + SECONDS SECURE SHORT SIGNED_kw STANDARD_BINARY STANDARD_DECIMAL STATEMENT STEP STRUCTURE @@ -1230,7 +1317,7 @@ TOWARD_LESSER TRUNCATION UCS_4 - UNDERLINE UNSIGNED + UNDERLINE UNSIGNED_kw UTF_16 UTF_8 @@ -1241,7 +1328,7 @@ END_EVALUATE END_MULTIPLY END_PERFORM END_READ END_RETURN END_REWRITE END_SEARCH END_START END_STRING END_SUBTRACT - END_UNSTRING END_WRITE + END_UNSTRING END_WRITE END_XML error END_IF @@ -1249,7 +1336,7 @@ %left OR %left AND %right NOT -%left '<' '>' '=' NE LE GE +%left '<' '>' EQ NE LE GE %left '-' '+' %left '*' '/' %right POW @@ -1308,7 +1395,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, @@ -1327,21 +1414,72 @@ return strlen(lit.data) == lit.len? lit.data : NULL; } - static inline char * string_of( _Float128 cce ) { - static const char empty[] = "", format[] = "%.32E"; - char output[64]; - int len = strfromf128 (output, sizeof(output), format, cce); - if( sizeof(output) < size_t(len) ) { - dbgmsg("string_of: value requires %d digits (of %zu)", - len, sizeof(output)); - return xstrdup(empty); + 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); } + static inline char * string_of( tree cce ) { + return string_of (TREE_REAL_CST (cce)); + } + cbl_field_t * new_literal( const literal_t& lit, enum cbl_field_attr_t attr ); @@ -1390,21 +1528,22 @@ id_div: cdf_words IDENTIFICATION_DIV '.' program_id cdf_words: %empty | cobol_words + /* | error { error_msg(@1, "not a COBOL-WORD"); } */ ; cobol_words: cobol_words1 | cobol_words cobol_words1 ; cobol_words1: COBOL_WORDS EQUATE NAME[keyword] WITH NAME[name] { - if( ! tokens.equate(@keyword, $keyword, $name) ) { YYERROR; } + if( ! cdf_tokens.equate(@keyword, $keyword, $name) ) { YYERROR; } } | COBOL_WORDS UNDEFINE NAME[keyword] { - if( ! tokens.undefine(@keyword, $keyword) ) { YYERROR; } + if( ! cdf_tokens.undefine(@keyword, $keyword) ) { YYERROR; } } | COBOL_WORDS SUBSTITUTE NAME[keyword] BY NAME[name] { - if( ! tokens.substitute(@keyword, $keyword, $name) ) { YYERROR; } + if( ! cdf_tokens.substitute(@keyword, $keyword, $name) ) { YYERROR; } } | COBOL_WORDS RESERVE NAME[name] { - if( ! tokens.reserve(@name, $name) ) { YYERROR; } + if( ! cdf_tokens.reserve(@name, $name) ) { YYERROR; } } ; @@ -1418,7 +1557,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; } @@ -1444,7 +1583,7 @@ program_as: %empty { static const literal_t empty {}; $$ = empty; } | AS LITERAL { $$ = $2; } ; -function_id: FUNCTION '.' NAME program_as program_attrs[attr] '.' +function_id: FUNCTION NAME program_as program_attrs[attr] '.' { internal_ebcdic_lock(); current_division = identification_div_e; @@ -1454,7 +1593,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() ) { @@ -1463,8 +1603,8 @@ function_id: FUNCTION '.' NAME program_as program_attrs[attr] '.' if( !current.new_program(@NAME, LblFunction, $NAME, $program_as.data, $attr.common, $attr.initial) ) { - auto L = symbol_program(current_program_index(), $NAME); - assert(L); + auto e = symbol_function(current_program_index(), $NAME); + auto L = cbl_label_of(e); error_msg(@NAME, "FUNCTION %s already defined on line %d", $NAME, L->line); YYERROR; @@ -1477,7 +1617,7 @@ function_id: FUNCTION '.' NAME program_as program_attrs[attr] '.' current.udf_add(current_program_index()); if( nparse_error > 0 ) YYABORT; } - | FUNCTION '.' NAME program_as is PROTOTYPE '.' + | FUNCTION NAME program_as is PROTOTYPE '.' { cbl_unimplemented("FUNCTION PROTOTYPE"); } @@ -1496,7 +1636,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 @@ -1518,21 +1658,25 @@ opt_round: DEFAULT ROUNDED mode is rounded_type[type] { } ; opt_entry: ENTRY_CONVENTION is COBOL { - yywarn("ENTRY-CONVENTION IS COBOL, check"); + cbl_message(ParInfoI, "ENTRY-CONVENTION IS COBOL"); } ; opt_binary: FLOAT_BINARY default_kw is HIGH_ORDER_LEFT { - cbl_unimplementedw("HIGH-ORDER-LEFT was ignored"); + cbl_unimplementedw(SynHighOrderBit, + "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"); + cbl_message(@3, SynHighOrderBit, + "unable to set %<HIGH_ORDER_LEFT%>"); } } | FLOAT_BINARY default_kw is HIGH_ORDER_RIGHT[opt] { - cbl_unimplementedw("HIGH-ORDER-RIGHT was ignored"); + cbl_unimplementedw(SynHighOrderBit, + "HIGH-ORDER-RIGHT was ignored"); if( ! current.option_binary(cbl_options_t::high_order_right_e) ) { - error_msg(@opt, "unable to set HIGH-ORDER-RIGHT"); + cbl_message(@opt, SynHighOrderBit, + "unable to set HIGH-ORDER-RIGHT"); } } ; @@ -1541,30 +1685,38 @@ default_kw: %empty ; opt_decimal: FLOAT_DECIMAL default_kw is HIGH_ORDER_LEFT[opt] { - cbl_unimplementedw("HIGH-ORDER-LEFT was ignored"); + cbl_unimplementedw(SynHighOrderBit, + "HIGH-ORDER-LEFT was ignored"); if( ! current.option_decimal(cbl_options_t::high_order_left_e) ) { - error_msg(@opt, "unable to set HIGH-ORDER-LEFT"); + cbl_message(@opt, SynHighOrderBit, + "unable to set HIGH-ORDER-LEFT"); } } | FLOAT_DECIMAL default_kw is HIGH_ORDER_RIGHT[opt] { - cbl_unimplementedw("HIGH-ORDER-RIGHT was ignored"); + cbl_unimplementedw(SynHighOrderBit, + "HIGH-ORDER-RIGHT was ignored"); if( ! current.option_decimal(cbl_options_t::high_order_right_e) ) { - error_msg(@opt, "unable to set HIGH-ORDER-RIGHT"); + cbl_message(@opt, SynHighOrderBit, + "unable to set HIGH-ORDER-RIGHT"); } } | FLOAT_DECIMAL default_kw is BINARY_ENCODING[opt] { - cbl_unimplementedw("BINARY-ENCODING was ignored"); + cbl_unimplementedw(SynHighOrderBit, + "BINARY-ENCODING was ignored"); if( ! current.option(cbl_options_t::binary_encoding_e) ) { - error_msg(@opt, "unable to set BINARY-ENCODING option"); + cbl_message(@opt, SynHighOrderBit, + "unable to set BINARY-ENCODING option"); } } | FLOAT_DECIMAL default_kw is DECIMAL_ENCODING[opt] { - cbl_unimplementedw("DECIMAL-ENCODING was ignored"); + cbl_unimplementedw(SynHighOrderBit, + "DECIMAL-ENCODING was ignored"); if( ! current.option(cbl_options_t::decimal_encoding_e) ) { - error_msg(@opt, "unable to set DECIMAL-ENCODING option"); + cbl_message(@opt, SynHighOrderBit, + "unable to set DECIMAL-ENCODING option"); } } ; @@ -1653,9 +1805,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); } } ; @@ -1748,7 +1900,8 @@ io_control_clause: } | APPLY COMMIT on field_list { - cbl_unimplementedw("I-O-CONTROL APPLY COMMIT"); + cbl_unimplementedw(SynApplyCommit, + "I-O-CONTROL APPLY COMMIT ignored"); } ; area: %empty @@ -1768,7 +1921,7 @@ select: SELECT optional NAME[name] select_clauses[clauses] '.' cbl_file_t *file = $clauses.file; file->optional = $optional; - file->line = yylineno; + file->line = @name.first_line; if( !namcpy(@clauses, file->name, $name) ) YYERROR; if( ! ($clauses.clauses & assign_clause_e) ) { @@ -1841,7 +1994,7 @@ select: SELECT optional NAME[name] select_clauses[clauses] '.' cbl_file_t file = protofile; file.optional = $optional; - file.line = yylineno; + file.line = @name.first_line; if( !namcpy(@name, file.name, $name) ) YYERROR; if( file_add(@name, &file) == NULL ) YYERROR; @@ -1856,11 +2009,12 @@ selected_name: external scalar { $$ = $2; } YYERROR; } uint32_t len = $name.len; - cbl_field_t field { - 0, FldLiteralA, FldInvalid, quoted_e | constant_e, - 0, 0, 0, nonarray, 0, "", 0, cbl_field_t::linkage_t(), - {len,len,0,0, $name.data}, NULL }; + // Pretend hex-encoded because that means use verbatim. + cbl_field_t field { FldLiteralA, + hex_encoded_e | quoted_e | constant_e, + {len,len,0,0, $name.data} }; field.attr |= literal_attr($name.prefix); + field.codeset.set(); $$ = new cbl_refer_t( field_add(@name, &field) ); } ; @@ -1885,7 +2039,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]; } { @@ -1897,8 +2051,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: @@ -1967,11 +2120,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: @@ -2129,14 +2282,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; + } ; /* @@ -2221,20 +2388,31 @@ config_paragraphs: config_paragraph config_paragraph: SPECIAL_NAMES '.' - | SPECIAL_NAMES '.' specials '.' - | SOURCE_COMPUTER '.' NAME with_debug '.' - | OBJECT_COMPUTER '.' NAME collating_sequence[name] '.' - { - if( $name ) { - if( !current.collating_sequence($name) ) { - error_msg(@name, "collating sequence already defined as '%s'", - current.collating_sequence()); - YYERROR; + | SPECIAL_NAMES '.' special_names '.' + { + std::reverse_iterator<symbol_elem_t *> + p(symbols_end()), + pend(symbols_begin(PROGRAM)); + for( ++p; p != pend; p++ ) { + if( p->type == SymAlphabet ) { + const auto& alphabet = *cbl_alphabet_of(&*p); + if( alphabet.encoding == no_encoding_e ) { + assert(alphabet.locale != 0 ); + const auto& missing = *cbl_locale_of(symbol_at(alphabet.locale)); + error_msg(alphabet.loc, + "ALPHABET %qs references LOCALE %qs, which is not defined", + alphabet.name, missing.name); + } } } } - | REPOSITORY '.' - | REPOSITORY '.' repo_members '.' + | SOURCE_COMPUTER '.' + | SOURCE_COMPUTER '.' NAME '.' + | SOURCE_COMPUTER '.' NAME with_debug '.' + | OBJECT_COMPUTER '.' + | OBJECT_COMPUTER '.' NAME[computer] object_computer '.' + | REPOSITORY dot + | REPOSITORY dot repo_members '.' ; repo_members: repo_member @@ -2262,38 +2440,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 { @@ -2325,7 +2526,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); } ; @@ -2333,23 +2534,100 @@ repo_program: PROGRAM_kw NAME repo_as repo_property: PROPERTY NAME repo_as ; -with_debug: %empty - | with DEBUGGING MODE { +with_debug: with DEBUGGING MODE { if( ! set_debug(true) ) { error_msg(@2, "DEBUGGING MODE valid only in fixed format"); } } ; -collating_sequence: %empty { $$ = NULL; } - | PROGRAM_kw COLLATING SEQUENCE is NAME[name] { $$ = $name; } - | PROGRAM_kw SEQUENCE is NAME[name] { $$ = $name; } - | COLLATING SEQUENCE is NAME[name] { $$ = $name; } - | SEQUENCE is NAME[name] { $$ = $name; } +object_computer: %empty + | char_classification + | collating_sequence + | char_classification collating_sequence + | collating_sequence char_classification + ; +char_classification: + character CLASSIFICATION char_class_locales[seq] + { + if( $seq.alpha ) { + auto e = symbol_locale(PROGRAM, $seq.alpha); + if( !e ) { + error_msg(@seq, "no LOCALE defined as %qs", $seq.alpha); + } else { + auto& encoding = cbl_locale_of(e)->encoding; + current.alpha_encoding(symbol_index(e), encoding); + } + } + if( $seq.national ) { + auto e = symbol_locale(PROGRAM, $seq.national); + if( !e ) { + error_msg(@seq, "no LOCALE defined as %qs", $seq.national); + } else { + auto& encoding = cbl_locale_of(e)->encoding; + current.national_encoding(symbol_index(e), encoding); + } + } + } + ; +collating_sequence: + program_kw collating SEQUENCE char_class_locales[seq] + { + if( !current.collating_sequence($seq.alpha) ) { + error_msg(@seq, "collating sequence already defined as '%s'", + current.collating_sequence()); + YYERROR; + } + } ; -specials: special_names +char_class_locales: + is NAME[name] { + $$.alpha = $name; + $$.national = nullptr; + } + | coll_alphanats { $$ = $1; } + ; +coll_alphanats: coll_alphanat[encoding] { + $$ = coll_alphanat_t(); + const char **pname = + $encoding.token == ALPHANUMERIC? &$$.alpha : &$$.national; + *pname = $encoding.name; + } + | coll_alphanats coll_alphanat[encoding] + { + const char **pname = + $encoding.token == ALPHANUMERIC? &$$.alpha : &$$.national; + if( *pname ) { + error_msg(@encoding, + "%qs is repeated", keyword_str($encoding.token)); + } + *pname = $encoding.name; + } ; +coll_alphanat: for alphanational is locale_phrase[locale] { + $$.token = $alphanational; + $$.name = $locale.name; + if( ! $locale.name ) { + const char *locale_name = "???"; + switch($locale.locale_type) { + case 'L': locale_name = "LOCALE"; break; + case 'D': locale_name = "DEFAULT"; break; + case 'S': locale_name = "SYSTEM-DEFAULT"; break; + case 'U': locale_name = "USER-DEFAULT"; break; + } + cbl_unimplemented("FOR %s IS %s", + keyword_str($$.token), + locale_name); + } + } + ; + +locale_phrase: NAME { $$.name = $1; $$.locale_type = '\0'; } + | LOCALE { $$.name = nullptr; $$.locale_type = 'L'; } + | DEFAULT { $$.name = nullptr; $$.locale_type = $1; } + ; + special_names: special_name | special_names special_name ; @@ -2362,12 +2640,26 @@ special_name: dev_mnemonic if( !namcpy(@name, $abc->name, $name) ) YYERROR; if( yydebug ) $abc->dump(); } + | ALPHABET NAME[name] for alphanational is alphabet_name[abc] + { + if( !$abc ) YYERROR; + assert($abc); // already in symbol table + if( !namcpy(@name, $abc->name, $name) ) YYERROR; + if( yydebug ) $abc->dump(); + const size_t isym = symbol_index(symbol_elem_of($abc)); + switch($alphanational) { + case ALPHANUMERIC: + current.alpha_encoding(isym, $abc->encoding); + break; + case NATIONAL: + current.national_encoding(isym, $abc->encoding); + break; + default: gcc_unreachable(); + } + } | CLASS NAME is domains { - struct cbl_field_t field = { 0, - FldClass, FldInvalid, 0, 0, 0, 0, nonarray, yylineno, "", - 0, cbl_field_t::linkage_t(), - {}, NULL }; + struct cbl_field_t field = { FldClass, 0, {}, 0, $NAME }; if( !namcpy(@NAME, field.name, $2) ) YYERROR; struct cbl_domain_t *domain = @@ -2377,6 +2669,7 @@ special_name: dev_mnemonic field.data.false_value_as($domains); field.data.domain_as(domain); + field.codeset.set(); domains.clear(); if( field_add(@2, &field) == NULL ) { @@ -2401,10 +2694,20 @@ special_name: dev_mnemonic { symbol_decimal_point_set(','); } - | LOCALE NAME is locale_spec + | LOCALE NAME is locale_spec[spec] { - current.locale($NAME, $locale_spec); - cbl_unimplemented("LOCALE syntax"); + cbl_locale_t locale($NAME, $spec); + if( locale.encoding == no_encoding_e ) { + error_msg(@NAME, "invalid iconv LOCALE name %qs", $spec); + YYERROR; + } + if( locale.encoding == UTF8_e ) { + cbl_unimplemented("UTF-8"); + YYERROR; + } + if( ! current.locale_add(locale) ) { + error_msg(@NAME, "%qs already defined as LOCALE name", $NAME); + } } ; | upsi @@ -2414,6 +2717,8 @@ special_name: dev_mnemonic } ; locale_spec: NAME { $$ = $1; } + | UTF_8 { static char s[] ="UTF-8"; $$ = s; } + | UTF_16 { static char s[] ="UTF-16"; $$ = s; } | LITERAL { $$ = string_of($1); } ; @@ -2453,23 +2758,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); } @@ -2505,13 +2801,29 @@ device_name: SYSIN { $$.token = SYSIN; $$.id = SYSIN_e; } | STDIN { $$.token = STDIN; $$.id = STDIN_e; } | STDOUT { $$.token = STDOUT; $$.id = STDOUT_e; } | STDERR { $$.token = STDERR; $$.id = STDERR_e; } + /* These cannot be both ctx_name and here. * + /* ARGUMENT_NUMBER { $$.token=0; $$.id = ARG_NUM_e; } */ + /* ENVIRONMENT_NAME { $$.token=0; $$.id = ENV_NAME_e; } */ + /* ENVIRONMENT_VALUE { $$.token=0; $$.id = ENV_VALUE_e; } */ ; -alphabet_name: STANDARD_ALPHABET { $$ = alphabet_add(@1, ASCII_e); } +alphabet_name: STANDARD_ALPHABET { $$ = alphabet_add(@1, CP1252_e); } | NATIVE { $$ = alphabet_add(@1, EBCDIC_e); } | EBCDIC { $$ = alphabet_add(@1, EBCDIC_e); } + | LOCALE locale_name[name] + { + auto e = symbol_locale(PROGRAM, $name); + if( !e ) { + dbgmsg("no such LOCALE yet %s", $name); + cbl_locale_t locale($name); // locale is named but not defined + e = symbol_locale_add(PROGRAM, &locale); + } + cbl_alphabet_t alphabet( @name, symbol_index(e), $name); + $$ = alphabet_add(alphabet); + } | alphabet_seqs { + $1->reencode(); $$ = cbl_alphabet_of(symbol_alphabet_add(PROGRAM, $1)); } | error @@ -2536,7 +2848,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); @@ -2589,17 +2902,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); } ; @@ -2708,22 +3023,12 @@ domains: domain domain: all LITERAL[a] { - if( ! string_of($a) ) { - gcc_location_set(@a); - yywarn("'%s' has embedded NUL", $a.data); - } $$ = NULL; cbl_domain_t domain(@a, $all, $a.len, $a.data); domains.push_back(domain); } | all[a_all] LITERAL[a] THRU all[z_all] LITERAL[z] { - if( ! string_of($a) ) { - yywarn("'%s' has embedded NUL", $a.data); - } - if( ! string_of($z) ) { - yywarn("'%s' has embedded NUL", $z.data); - } $$ = NULL; cbl_domain_elem_t first(@a, $a_all, $a.len, $a.data), last(@z, $z_all, $z.len, $z.data); @@ -2750,9 +3055,6 @@ domain: all LITERAL[a] domains.push_back(domain); } | all[a_all] reserved_value[a] THRU all[z_all] LITERAL[z] { - if( ! string_of($z) ) { - yywarn("'%s' has embedded NUL", $z.data); - } $$ = NULL; if( $a == NULLS ) YYERROR; auto value = constant_of(constant_index($a))->data.initial; @@ -2770,10 +3072,7 @@ domain: all LITERAL[a] } | when_set_to FALSE_kw is LITERAL[value] { - 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 @@ -2853,7 +3152,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; } @@ -2874,10 +3173,42 @@ fd_clause: record_desc error_msg(@NAME, "invalid RECORDING MODE '%s'", $NAME); YYERROR; } - cbl_unimplementedw("RECORDING MODE was ignored, not defined by ISO 2023"); + cbl_unimplementedw(SynRecordingMode, + "RECORDING MODE ignored"); } | VALUE OF fd_values - | CODESET is NAME + | CODESET is codeset_name[codeset] { + auto f = cbl_file_of(symbol_at(file_section_fd)); + f->codeset = cbl_file_t::codeset_t($codeset.encoding, + $codeset.isym); + cbl_unimplementedw(SynFileCodeSet, + "sorry, unimplemented CODE-SET"); + } + | CODESET for alphanational is codeset_name[codeset] + { + auto f = cbl_file_of(symbol_at(file_section_fd)); + f->codeset = cbl_file_t::codeset_t($codeset.encoding, + $codeset.isym); + if( $codeset.isym == 0 ) { + switch( $alphanational) { + case ALPHANUMERIC: + if( $codeset.encoding != ASCII_e ) { + error_msg(@alphanational, + "FOR ALPHANUMERIC: invalid codeset"); + } + break; + case NATIONAL: + if( $codeset.encoding != EBCDIC_e ) { + error_msg(@alphanational, + "FOR ALPHANUMERIC: invalid codeset"); + } + break; + default: + gcc_unreachable(); + } + } + cbl_unimplemented("CODE-SET"); + } | is GLOBAL { auto f = cbl_file_of(symbol_at(file_section_fd)); @@ -2892,40 +3223,62 @@ 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; } ; -block_desc: BLOCK contains rec_contains chars_recs +alphanational: ALPHANUMERIC { $$ = ALPHANUMERIC; } + | NATIONAL { $$ = NATIONAL; } + ; +codeset_name: STANDARD_ALPHABET { $$.isym = 0; $$.encoding = ASCII_e; } + | NATIVE { $$.isym = 0; $$.encoding = EBCDIC_e; } + | EBCDIC { $$.isym = 0; $$.encoding = EBCDIC_e; } + | NAME + { + auto e = symbol_alphabet(PROGRAM, $NAME); + if( !e ) { + error_msg(@NAME, "invalid CODE-SET: %qs", $NAME); + YYERROR; + } + $$.isym = symbol_index(e); + $$.encoding = custom_encoding_e; + } + ; + +block_desc: BLOCK_kw contains rec_contains chars_recs ; rec_contains: NUMSTR[min] { - ssize_t n; - if( (n = numstr2i($min.string, $min.radix)) < 0 ) { + REAL_VALUE_TYPE rn = numstr2i($min.string, $min.radix); + ssize_t n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@min, "size %s cannot be negative", $min.string); YYERROR; } $$.min = $$.max = n; // fixed length } | NUMSTR[min] TO NUMSTR[max] { - ssize_t n; - if( (n = numstr2i($min.string, $min.radix)) < 0 ) { + REAL_VALUE_TYPE rn = numstr2i($min.string, $min.radix); + ssize_t n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@min, "size %s cannot be negative", $min.string); YYERROR; } $$.min = n; - if( (n = numstr2i($max.string, $max.radix)) < 0 ) { + rn = numstr2i($max.string, $max.radix); + n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@max, "size %s cannot be negative", $max.string); YYERROR; } $$.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; } @@ -2978,26 +3331,32 @@ in_size: IN SIZE ; from_to: FROM NUMSTR[min] TO NUMSTR[max] characters { - ssize_t n; - if( (n = numstr2i($min.string, $min.radix)) < 0 ) { + REAL_VALUE_TYPE rn = numstr2i($min.string, $min.radix); + ssize_t n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@min, "size %s cannot be negative", $min.string); YYERROR; } $$.min = n; - if( (n = numstr2i($max.string, $max.radix)) < 0 ) { + rn = numstr2i($max.string, $max.radix); + n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@min, "size %s cannot be negative", $max.string); YYERROR; } $$.max = n; } | NUMSTR[min] TO NUMSTR[max] characters { - ssize_t n; - if( (n = numstr2i($min.string, $min.radix)) < 0 ) { + REAL_VALUE_TYPE rn = numstr2i($min.string, $min.radix); + ssize_t n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@min, "size %s cannot be negative", $min.string); YYERROR; } $$.min = n; - if( (n = numstr2i($max.string, $max.radix)) < 0 ) { + rn = numstr2i($max.string, $max.radix); + n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@max, "size %s cannot be negative", $max.string); YYERROR; } @@ -3005,8 +3364,9 @@ from_to: FROM NUMSTR[min] TO NUMSTR[max] characters { } | TO NUMSTR[max] characters { - ssize_t n; - if( (n = numstr2i($max.string, $max.radix)) < 0 ) { + REAL_VALUE_TYPE rn = numstr2i($max.string, $max.radix); + ssize_t n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@max, "size %s cannot be negative", $max.string); YYERROR; } @@ -3015,8 +3375,9 @@ from_to: FROM NUMSTR[min] TO NUMSTR[max] characters { } | FROM NUMSTR[min] characters { - ssize_t n; - if( (n = numstr2i($min.string, $min.radix)) < 0 ) { + REAL_VALUE_TYPE rn = numstr2i($min.string, $min.radix); + ssize_t n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@min, "size %s cannot be negative", $min.string); YYERROR; } @@ -3024,8 +3385,9 @@ from_to: FROM NUMSTR[min] TO NUMSTR[max] characters { $$.max = size_t(-1); } | NUMSTR[min] characters { - ssize_t n; - if( (n = numstr2i($min.string, $min.radix)) < 0 ) { + REAL_VALUE_TYPE rn = numstr2i($min.string, $min.radix); + ssize_t n = real_to_integer (&rn); + if( n < 0 ) { error_msg(@min, "size %s cannot be negative", $min.string); YYERROR; } @@ -3049,7 +3411,7 @@ depending: %empty assert(e->type == SymField); odo = symbol_index(e); } else { - e = symbol_field_forward_add(PROGRAM, 0, $NAME, yylineno); + e = symbol_field_forward_add(PROGRAM, 0, $NAME, @NAME.first_line); if( !e ) YYERROR; symbol_field_location( symbol_index(e), @NAME ); odo = field_index(cbl_field_of(e)); @@ -3098,7 +3460,7 @@ field: cdf // Format data.initial per picture if( 0 == pristine_values.count(field.data.initial) ) { - if( field.data.digits > 0 && field.data.value_of() != 0.0 ) { + if( field.data.digits > 0 && !field.is_zero() ) { char *initial; int rdigits = field.data.rdigits < 0? 1 : field.data.rdigits + 1; @@ -3112,7 +3474,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(); @@ -3145,7 +3507,7 @@ occurs_clause: OCCURS cardinal_lb indexed } cbl_occurs_t *occurs = ¤t_field()->occurs; occurs->bounds.lower = - occurs->bounds.upper = $name->data.value_of(); + occurs->bounds.upper = $name->as_integer(); } ; cardinal_lb: cardinal times { @@ -3156,7 +3518,8 @@ cardinal_lb: cardinal times { cardinal: NUMSTR[input] { - $$ = numstr2i( $input.string, $input.radix ); + REAL_VALUE_TYPE rn = numstr2i($input.string, $input.radix); + $$ = real_to_integer (&rn); } ; @@ -3217,11 +3580,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; } @@ -3246,11 +3609,8 @@ level_name: LEVEL ctx_name error_msg(@LEVEL, "LEVEL %d not supported", $LEVEL); YYERROR; } - struct cbl_field_t field = { 0, - FldInvalid, FldInvalid, 0, 0, 0, capacity_cast($1), - nonarray, yylineno, "", - 0, cbl_field_t::linkage_t(), - {}, NULL }; + cbl_field_t field = { FldInvalid, capacity_cast($LEVEL), + @ctx_name.first_line }; if( !namcpy(@ctx_name, field.name, $2) ) YYERROR; $$ = field_add(@$, &field); @@ -3271,10 +3631,9 @@ level_name: LEVEL ctx_name error_msg(@LEVEL, "LEVEL %d not supported", $LEVEL); YYERROR; } - struct cbl_field_t field = { 0, - FldInvalid, FldInvalid, 0, 0, 0, capacity_cast($1), - nonarray, yylineno, "", - 0, {}, {}, NULL }; + struct cbl_field_t field = { FldInvalid, + capacity_cast($LEVEL), + @LEVEL.first_line }; $$ = field_add(@1, &field); if( !$$ ) { @@ -3287,36 +3646,40 @@ 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.capacity; } - | LENGTH of name { $$ = $name->data.capacity; } - | LENGTH_OF of name { $$ = $name->data.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 { - cbl_field_data_t data = {}; - data.capacity = capacity_cast(strlen($1.data)); - data.initial = $1.data; - $$ = new cbl_field_data_t(data); + cbl_field_data_t data; + data.capacity = capacity_cast(strlen($1.data)); + data.initial = $1.data; + $$.encoding = $1.encoding; + $$.data = new cbl_field_data_t(data); } | const_value { - cbl_field_data_t data = {}; - data = $1; - $$ = new cbl_field_data_t(data); + cbl_field_data_t data; + data = build_real (float128_type_node, $1); + $$.encoding = current_encoding('A'); + $$.data = new cbl_field_data_t(data); } + | reserved_value[value] + { + const auto field = constant_of(constant_index($value)); + $$.encoding = current_encoding('A'); + $$.data = new cbl_field_data_t(field->data); + } + | true_false { cbl_unimplemented("Boolean constant"); @@ -3343,13 +3706,29 @@ data_descr1: level_name field.attr |= constant_e; if( $is_global ) field.attr |= global_e; field.type = FldLiteralN; - field.data = $const_value; + field.data = build_real (float128_type_node, $const_value); field.data.initial = string_of($const_value); + field.codeset.set(); - if( !cdf_value(field.name, static_cast<int64_t>($const_value)) ) { + if( !cdf_value(field.name, cdfval_t($const_value)) ) { 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; @@ -3366,6 +3745,11 @@ data_descr1: level_name if( !cdf_value(field.name, $lit.data) ) { error_msg(@1, "%s was defined by CDF", field.name); } + if( ! field.codeset.set() ) { + error_msg(@lit, "CONSTANT inconsistent with encoding %s", + cbl_alphabet_t::encoding_str(field.codeset.encoding)); + } + value_encoding_check(@lit, $1); } | level_name CONSTANT is_global FROM NAME @@ -3389,25 +3773,23 @@ data_descr1: level_name | LEVEL78 NAME[name] VALUE is value78[data] { - if( ! dialect_mf() ) { - dialect_error(@1, "level 78", "mf"); - YYERROR; - } - struct cbl_field_t field = { 0, FldLiteralA, FldInvalid, - constant_e, 0, 0, 78, nonarray, - yylineno, "", 0, {}, *$data, NULL }; - if( !namcpy(@name, field.name, $name) ) YYERROR; + dialect_ok(@1, MfLevel78, "LEVEL 78"); + cbl_field_t field = { FldLiteralA, constant_e, *$data.data, + 78, $name, @name.first_line }; if( field.data.initial ) { field.attr |= quoted_e; + field.codeset.set($data.encoding); if( !cdf_value(field.name, field.data.initial) ) { - yywarn("%s was defined by CDF", field.name); + cbl_message(Par78CdfDefinedW, + "%s was defined by CDF", field.name); } } else { field.type = FldLiteralN; field.data.initial = string_of(field.data.value_of()); - if( !cdf_value(field.name, - static_cast<int64_t>(field.data.value_of())) ) { - yywarn("%s was defined by CDF", field.name); + field.codeset.set($data.encoding); + if( !cdf_value(field.name, field.as_integer()) ) { + cbl_message(Par78CdfDefinedW, + "%s was defined by CDF", field.name); } } if( ($$ = field_add(@name, &field)) == NULL ) { @@ -3418,10 +3800,8 @@ data_descr1: level_name | LEVEL88 NAME /* VALUE */ NULLPTR { - struct cbl_field_t field = { 0, - FldClass, FldInvalid, 0, 0, 0, 88, nonarray, yylineno, "", - 0, cbl_field_t::linkage_t(), - {}, NULL }; + struct cbl_field_t field = {FldClass, 0, {}, + 88, $NAME, @NAME.first_line}; if( !namcpy(@NAME, field.name, $2) ) YYERROR; auto fig = constant_of(constant_index(NULLS))->data.initial; @@ -3444,19 +3824,16 @@ data_descr1: level_name } | LEVEL88 NAME VALUE domains { - struct cbl_field_t field = { 0, - FldClass, FldInvalid, 0, 0, 0, 88, nonarray, yylineno, "", - 0, cbl_field_t::linkage_t(), - {}, NULL }; - if( !namcpy(@NAME, field.name, $2) ) YYERROR; - - struct cbl_domain_t *domain = + cbl_field_t field = { + FldClass, 0, {}, 88, $NAME, @NAME.first_line}; + cbl_domain_t *domain = new cbl_domain_t[ domains.size() + 1]; std::copy(domains.begin(), domains.end(), domain); field.data.domain_as(domain); field.data.false_value_as($domains); + field.codeset.set(); domains.clear(); if( ($$ = field_add(@2, &field)) == NULL ) { @@ -3550,7 +3927,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; @@ -3592,7 +3969,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: @@ -3605,12 +3982,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 ) { @@ -3653,15 +4030,14 @@ data_descr1: level_name } // Ensure signed initial VALUE is for signed numeric type - if( is_numeric($field) && - $field->data.initial && - $field->type != FldFloat ) - { - switch( $field->data.initial[0] ) { - case '-': - if( !$field->has_attr(signable_e) ) { - error_msg(@field, "%s is unsigned but has signed VALUE '%s'", - $field->name, $field->data.initial); + if( is_numeric($field) ) { + if( $field->data.initial && $field->type != FldFloat ) { + switch( $field->data.initial[0] ) { + case '-': + if( !$field->has_attr(signable_e) ) { + error_msg(@field, "%s is unsigned but has signed VALUE '%s'", + $field->name, $field->data.initial); + } } } } @@ -3669,8 +4045,17 @@ data_descr1: level_name // Verify VALUE $field->report_invalid_initial_value(@data_clauses); + bool numerical = + $field->type == FldNumericDisplay || is_numeric($field); + + if( $field->data.initial && ! numerical ) { + if( normal_value_e == cbl_figconst_of($field->data.initial) ) { + value_encoding_check(@data_clauses, $field); + } + } + // 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 } @@ -3691,8 +4076,9 @@ literalism: LITERAL { $$ = $1; } if( $second.prefix[0] ) { strcpy(output.prefix, $second.prefix); } if( ! $first.compatible_prefix($second) ) { - yywarn("dissimilar literals, '%s' prevails", - output.prefix); + cbl_message(@$, ParLiteral2W, + "dissimilar literals, '%s' prevails", + output.prefix); } } ; @@ -3766,7 +4152,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; @@ -3802,12 +4188,11 @@ data_clauses: data_clause if( field->is_binary_integer() && field->data.capacity == 4) { 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", - field->name, field->size(), sizeof(void*), - redefined->name); - } + dbgmsg("expanding %s size from %u bytes to %lu " + "because it redefines %s with USAGE POINTER", + field->name, field->size(), + int_size_in_bytes(ptr_type_node), + redefined->name); field->embiggen(); } } @@ -3841,7 +4226,7 @@ data_clause: any_length { $$ = any_length_e; } cbl_field_t *field = current_field(); switch( field->level ) { case 1: - if( dialect_mf() ) break; + if( dialect_ok(@$, MfLevel_1_Occurs, "LEVEL 01 for OCCURS") ) break; __attribute__((fallthrough)); case 77: case 88: @@ -3896,7 +4281,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); } @@ -3919,16 +4304,17 @@ picture_clause: PIC signed nps[fore] nines nps[aft] { cbl_field_t *field = current_field(); field->data.digits = $left + $rdigits; + field->attr |= $signed; if( field->is_binary_integer() ) { field->data.capacity = type_capacity(field->type, field->data.digits); + field->data.rdigits = $rdigits; } else { if( !field_type_update(field, FldNumericDisplay, @$) ) { YYERROR; } ERROR_IF_CAPACITY(@PIC, field); - field->attr |= $signed; field->data.capacity = field->data.digits; field->data.rdigits = $rdigits; } @@ -3962,15 +4348,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_ok(@2, MfCompX, "alphanumeric PICTURE with numeric USAGE") ) { // 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; } } @@ -3978,14 +4365,16 @@ picture_clause: PIC signed nps[fore] nines nps[aft] if( field->data.initial != NULL ) { if( 0 < field->data.capacity && field->data.capacity < uint32_t($size) ) { - auto p = blank_pad_initial( field->data.initial, - field->data.capacity, $size ); + auto p = blank_pad_initial(field->data.initial, + field->data.capacity, $size ); if( !p ) YYERROR; field->data.initial = p; } } - field->data.capacity = $size; + charmap_t *charmap = + __gg__get_charmap(field->codeset.encoding); + field->data.capacity = $size * charmap->stride(); field->data.picture = NULL; if( false ) dbgmsg("PIC alphanum_pic[size]:%d: %s", @@ -4000,7 +4389,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; @@ -4042,7 +4431,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); @@ -4065,6 +4460,11 @@ alphanum_pic: alphanum_part { ; alphanum_part: ALNUM[picture] count { + auto field = current_field(); + if( ! field->codeset.set($picture) ) { + error_msg(@picture, "PICTURE inconsistent with encoding %s", + cbl_alphabet_t::encoding_str(field->codeset.encoding)); + } $$.attr = uniform_picture($picture); $$.nbyte = strlen($picture); auto count($count); @@ -4073,7 +4473,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; } } @@ -4092,7 +4492,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)"); } } ; @@ -4103,16 +4503,17 @@ nines: NINES count: %empty { $$ = 0; } | '(' NUMSTR ')' { - $$ = numstr2i( $NUMSTR.string, $NUMSTR.radix ); + 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; @@ -4120,15 +4521,18 @@ count: %empty { $$ = 0; } if( e ) { // verify not floating point with nonzero fraction auto field = cbl_field_of(e); assert(is_literal(field)); - if( field->data.value_of() != size_t(field->data.value_of()) ) { + REAL_VALUE_TYPE vi; + real_from_integer (&vi, VOIDmode, field->as_integer(), SIGNED); + 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 ); } } ; @@ -4147,11 +4551,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. @@ -4167,21 +4581,15 @@ 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() ) { - field->type = $comp.type; - field->clear_attr(signable_e); - } else { - error_msg(@comp, "numeric USAGE invalid " - "with Alpnanumeric PICTURE"); - YYERROR; - } + dialect_ok(@2, MfCompX, "alphanumeric PICTURE with numeric USAGE"); + + field->type = $comp.type; + field->clear_attr(signable_e); 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"); - } + dialect_ok(@2, MfCompX, "alphanumeric PICTURE with numeric USAGE"); } field->type = $comp.type; field->data.capacity = type_capacity(field->type, @@ -4194,9 +4602,78 @@ usage_clause1: usage COMPUTATIONAL[comp] native 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"); + dialect_ok(@2, MfComp6, "COMP-6"); + 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 ); + dialect_ok(@2, MfCompX, "alphanumeric PICTURE with numeric USAGE"); + field->type = $comp.type; + field->clear_attr(signable_e); + 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 ); + dialect_ok(@2, MfCompX, "alphanumeric PICTURE with numeric USAGE"); + } + 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; + dialect_ok(@2, MfComp6, "COMP-6"); if( field->type == FldNumericDisplay ) {// PICTURE before USAGE infer = false; assert(field->data.capacity > 0); @@ -4248,6 +4725,13 @@ usage_clause1: usage COMPUTATIONAL[comp] native | usage INDEX { $$ = symbol_field_index_set( current_field() )->type; } + | usage NATIONAL { + auto field = current_field(); + if( ! field->codeset.set(EBCDIC_e) ) { + error_msg(@2, "usage NATIONAL conflicts with PICTURE"); + } + $$ = FldInvalid; + } // We should enforce data/code pointers with a different type. | usage POINTER { @@ -4261,9 +4745,10 @@ usage_clause1: usage COMPUTATIONAL[comp] native if( gcobol_feature_embiggen() && redefined && is_numeric(redefined->type) && redefined->size() == 4) { // For now, we allow POINTER to expand a 32-bit item to 64 bits. - field->data.capacity = sizeof(void *); - dbgmsg("%s: expanding #%zu %s capacity %u => %u", __func__, - field_index(redefined), redefined->name, + field->data.capacity = int_size_in_bytes(ptr_type_node); + 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(); @@ -4284,10 +4769,23 @@ usage_clause1: usage COMPUTATIONAL[comp] native value_clause: VALUE all LITERAL[lit] { cbl_field_t *field = current_field(); + + if( $lit.prefix[0] ) { // not the default encoding + if( ! field->codeset.set($lit.encoding) ) { + error_msg(@lit, "VALUE inconsistent with encoding %s", + cbl_alphabet_t::encoding_str(field->codeset.encoding)); + } + } else { + field->codeset.set(); + } + + if( field->codeset.encoding != $lit.encoding ) { + error_msg(@lit, "PICTURE inconsistent with VALUE %s'%s'", + $lit.prefix, $lit.data); + } + field->data.initial = $lit.data; field->attr |= literal_attr($lit.prefix); - // The __gg__initialize_data routine needs to know that VALUE is a - // quoted literal. This is critical for NumericEdited variables field->attr |= quoted_e; if( field->data.capacity == 0 ) { @@ -4304,15 +4802,16 @@ value_clause: VALUE all LITERAL[lit] { } } } - value_encoding_check(@lit, field); } | VALUE all cce_expr[value] { cbl_field_t *field = current_field(); auto orig_str = original_number(); - auto orig_val = numstr2i(orig_str, decimal_e); + REAL_VALUE_TYPE orig_val; + real_from_string3 (&orig_val, orig_str, + TYPE_MODE (float128_type_node)); char *initial = NULL; - if( orig_val == $value ) { + if( real_identical (&orig_val, &$value) ) { initial = orig_str; pristine_values.insert(initial); } else { @@ -4324,21 +4823,28 @@ value_clause: VALUE all LITERAL[lit] { std::replace(initial, initial + strlen(initial), '.', decimal); field->data.initial = initial; - field->data = $value; + field->data = build_real (float128_type_node, $value); if( $all ) field_value_all(field); } | VALUE all reserved_value[value] { + cbl_field_t *field = current_field(); + if( ! field->codeset.set() ) { + error_msg(@value, "VALUE inconsistent with encoding %s", + cbl_alphabet_t::encoding_str(field->codeset.encoding)); + } if( $value != NULLS ) { auto fig = constant_of(constant_index($value)); - current_field()->data.initial = fig->data.initial; + cbl_field_t *field = current_field(); + field->data.initial = fig->data.initial; } } | /* VALUE is */ NULLPTR { auto fig = constant_of(constant_index(NULLS)); - current_field()->data.initial = fig->data.initial; + cbl_field_t *field = current_field(); + field->data.initial = fig->data.initial; } | VALUE error { @@ -4368,7 +4874,7 @@ justified_clause: is JUSTIFIED redefines_clause: REDEFINES NAME[orig] { - struct symbol_elem_t *e = field_of($orig); + struct symbol_elem_t *e = symbol_field(PROGRAM, 0, $orig); if( !e ) { error_msg(@2, "REDEFINES target not defined"); YYERROR; @@ -4428,10 +4934,13 @@ any_length: ANY LENGTH if( field->attr & any_length_e ) { error_msg(@1, "ANY LENGTH already set"); } + const char *prog_name = current.program()->name; + bool is_compat = 0 < compat_programs.count(prog_name); if( ! (field->level == 1 && current_data_section == linkage_datasect_e && (1 < current.program_level() || - current.program()->is_function())) ) { + current.program()->is_function() || + is_compat)) ) { error_msg(@1, "ANY LENGTH valid only for 01 " "in LINKAGE SECTION of a function or contained program"); YYERROR; @@ -4504,7 +5013,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 ); } ; @@ -4515,7 +5024,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; @@ -4553,19 +5062,16 @@ 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 ); } } | USAGE is typename { - if( ! dialect_mf() ) { - dialect_error(@typename, "USAGE TYPENAME", "mf"); - YYERROR; - } + dialect_ok(@typename, MfUsageTypename, "USAGE 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 ); } } @@ -4580,6 +5086,7 @@ typedef_clause: is TYPEDEF strong error_msg(@2, "%s %s IS TYPEDEF must be level 01", field->level_str(), field->name); } + field->codeset.set(); field->attr |= typedef_e; if( $strong ) field->attr |= strongdef_e; if( ! current.typedef_add(field) ) { @@ -4596,10 +5103,8 @@ typedef_clause: is TYPEDEF strong volatile_clause: VOLATILE { - if( dialect_ibm() ) { - yywarn("VOLATILE has no effect"); - } else { - dialect_error(@1, "VOLATILE", "ibm"); + if( dialect_ok(@1, IbmVolatileE, "VOLATILE") ) { + cbl_message(@1, IbmVolatileW, "VOLATILE has no effect"); } } ; @@ -4668,6 +5173,7 @@ by_value_arg: scalar declaratives: %empty | DECLARATIVES '.' <label>{ + cbl_enabled_exceptions_t& enabled_exceptions( cdf_enabled_exceptions() ); current.enabled_exception_cache = enabled_exceptions; enabled_exceptions.clear(); current.doing_declaratives(true); @@ -4686,6 +5192,7 @@ declaratives: %empty * forward reference, because we haven't yet begun to parse * nondeclarative procedures. */ + cbl_enabled_exceptions_t& enabled_exceptions( cdf_enabled_exceptions() ); parser_label_label($label); enabled_exceptions = current.enabled_exception_cache; current.enabled_exception_cache.clear(); @@ -4754,10 +5261,9 @@ sentence: statements '.' std::set<std::string> externals = current.end_program(); if( !externals.empty() ) { for( const auto& name : externals ) { - yywarn("%s calls external symbol '%s'", + dbgmsg("%s calls external symbol '%s'", prog->name, name.c_str()); } - YYERROR; } // pointer still valid because name is in symbol table ast_end_program(prog->name); @@ -4778,12 +5284,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; } } @@ -4801,6 +5306,7 @@ statement: error { | divide { $$ = DIVIDE; } | entry { $$ = ENTRY; } | evaluate { $$ = EVALUATE; } + | exhibit_stmt { $$ = EXHIBIT; } | exit { $$ = EXIT; } | free { $$ = FREE; } | go_to { $$ = GOTO; } @@ -4827,13 +5333,14 @@ statement: error { | subtract { $$ = SUBTRACT; } | unstring { $$ = UNSTRING; } | write { $$ = WRITE; } - ; + | xmlgenerate { $$ = XMLGENERATE; } + | xmlparse { $$ = XMLPARSE; } + ; /* * ISO defines ON EXCEPTION only for Format 3 (screen). We - * implement extensions defined by MF and Fujitsu (and us) to - * use ACCEPT to interact with the command line and the - * environment. + * implement extensions defined by MF and Fujitsu to use ACCEPT + * to interact with the command line and the environment. * * ISO ACCEPT and some others are implemented in accept_body, * before the parser sees any ON EXCEPTION. In those cases @@ -4848,6 +5355,9 @@ accept: accept_body end_accept { switch( $accept_body.func ) { case accept_done_e: break; + case accept_e: + parser_accept(*$1.into, $1.special, nullptr, nullptr); + break; case accept_command_line_e: if( $1.from->field == NULL ) { // take next command-line arg parser_accept_command_line(*$1.into, argi, NULL, NULL); @@ -4869,7 +5379,10 @@ accept: accept_body end_accept { switch( $accept_body.func ) { case accept_done_e: error_msg(@ec, "ON EXCEPTION valid only " - "with ENVIRONMENT or COMAMND-LINE(n)"); + "with ENVIRONMENT or COMMAND-LINE(n)"); + break; + case accept_e: + parser_accept(*$1.into, $1.special, $ec.on_error, $ec.not_error); break; case accept_command_line_e: if( $1.from->field == NULL ) { // take next command-line arg @@ -4881,7 +5394,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, @@ -4902,7 +5415,7 @@ end_accept: %empty %prec ACCEPT accept_body: accept_refer { $$.func = accept_done_e; - parser_accept(*$1, CONSOLE_e); + parser_accept(*$1, CONSOLE_e, nullptr, nullptr); } | accept_refer FROM DATE { @@ -4961,29 +5474,15 @@ accept_body: accept_refer } | accept_refer FROM acceptable { - cbl_field_t *argc = register_find("_ARGI"); - switch( $acceptable->id ) { - case ARG_NUM_e: - $$.func = accept_command_line_e; - $$.into = $1; - $$.from = new_reference(argc); - break; - case ARG_VALUE_e: - $$.func = accept_command_line_e; - $$.into = $1; - $$.from = cbl_refer_t::empty(); - break; - default: - $$.func = accept_done_e; - parser_accept( *$1, $acceptable->id ); - } + $$.func = accept_e; + $$.into = $1; + $$.special = $acceptable->id; } | accept_refer FROM ENVIRONMENT envar { $$.func = accept_envar_e; $$.into = $1; $$.from = $envar; - //// parser_accept_envar( *$1, *$envar ); } | accept_refer FROM COMMAND_LINE { @@ -4995,7 +5494,6 @@ accept_body: accept_refer $$.func = accept_command_line_e; $$.into = $1; $$.from = $expr; - //// parser_accept_command_line(*$1, $expr->field ); } | accept_refer FROM COMMAND_LINE_COUNT { $$.func = accept_done_e; @@ -5048,7 +5546,7 @@ accept_except: EXCEPTION { $$.not_error = NULL; $$.on_error = label_add(LblArith, - uniq_label("accept"), yylineno); + uniq_label("accept"), @1.first_line); if( !$$.on_error ) YYERROR; parser_accept_exception( $$.on_error ); @@ -5078,9 +5576,58 @@ acceptable: device_name { $$ = special_of($1); if( !$$ ) { - error_msg(@NAME, "no such environment mnemonic name: %s", $NAME); - YYERROR; - } + const special_name_t *special_type = cmd_or_env_special_of($NAME); + if( !special_type ) { + error_msg(@NAME, "no such special name '%s'", $NAME); + YYERROR; + } + if( ENV_NAME_e == *special_type ) { + error_msg(@NAME, "cannot ACCEPT FROM %qs", $NAME); + YYERROR; + } + // Add the name now, as a convenience. + int token = 0; + switch(*special_type) { + case ARG_NUM_e: token = ARGUMENT_NUMBER; break; + case ARG_VALUE_e: token = ARGUMENT_VALUE; break; + case ENV_VALUE_e: token = ENVIRONMENT_VALUE; break; + + case ENV_NAME_e: + default: + error_msg(@NAME, "cannot ACCEPT FROM %qs", $NAME); + YYERROR; + break; + } + cbl_special_name_t special = { token, *special_type }; + namcpy(@NAME, special.name, $NAME); + + symbol_elem_t *e = symbol_special_add(PROGRAM, &special); + $$ = cbl_special_name_of(e); + cbl_special_name_t& unused(*$$); + assert(unused.id); + } + assert($$); + } + | ENVIRONMENT_VALUE { + // Add the name now, as a convenience. + cbl_special_name_t special = + { ENVIRONMENT_VALUE, ENV_VALUE_e, "ENVIRONMENT-VALUE" }; + symbol_elem_t *e = symbol_special_add(PROGRAM, &special); + $$ = cbl_special_name_of(e); + } + | ARGUMENT_NUMBER { + // Add the name now, as a convenience. + cbl_special_name_t special = + { ARGUMENT_NUMBER, ARG_NUM_e, "ARGUMENT-NUMBER" }; + symbol_elem_t *e = symbol_special_add(PROGRAM, &special); + $$ = cbl_special_name_of(e); + } + | ARGUMENT_VALUE { + // Add the name now, as a convenience. + cbl_special_name_t special = + { ARGUMENT_VALUE, ARG_VALUE_e, "ARGUMENT-VALUE" }; + symbol_elem_t *e = symbol_special_add(PROGRAM, &special); + $$ = cbl_special_name_of(e); } ; @@ -5133,9 +5680,10 @@ add_body: sum TO rnames corresponding_arith_fields( $sum->refers.front().field, rhs.front().refer.field ); if( pairs.empty() ) { - yywarn( "%s and %s have no corresponding fields", - $sum->refers.front().field->name, - rhs.front().refer.field->name ); + cbl_message( @$, ParNoCorrespondingW, + "%s and %s have no corresponding fields", + $sum->refers.front().field->name, + rhs.front().refer.field->name ); } // First src/tgt elements are templates. // Their subscripts apply to the correspondents. @@ -5197,16 +5745,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] { @@ -5235,7 +5780,8 @@ allocate: ALLOCATE expr[size] CHARACTERS initialized RETURNING scalar[retu { statement_begin(@1, ALLOCATE); if( $size->field->type == FldLiteralN ) { - if( $size->field->data.value_of() <= 0 ) { + 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; } @@ -5275,7 +5821,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] @@ -5283,7 +5829,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 @@ -5297,69 +5843,36 @@ compute_body: rnames { statement_begin(@$, COMPUTE); } compute_expr[expr] { $$.expr = $expr; } ; -compute_expr: '=' { +compute_expr: EQ { + if( $1[0] == 'E' ) { // lexer found EQUALS keyword + dialect_ok(@1, IbmEqualAssignE, + "EQUAL as assignment operator" ); + } current.compute_begin(); } expr { $$ = $expr; } ; - | EQUAL { - if( ! dialect_ibm() ) { - dialect_error(@1, "EQUAL invalid as assignment operator", "ibm"); - } - current.compute_begin(); - } expr { - $$ = $expr; - } - ; -display: disp_body end_display - { - std::vector <cbl_refer_t> args($1.vargs->args.size()); - std::copy( $1.vargs->args.begin(), $1.vargs->args.end(), args.begin() ); - if( $1.special && $1.special->id == ARG_NUM_e ) { - if( $1.vargs->args.size() != 1 ) { - error_msg(@1, "ARGUMENT-NUMBER can be set to only one value"); - } - cbl_refer_t& src( $1.vargs->args.front() ); - cbl_field_t *dst = register_find("_ARGI"); - parser_move( dst, src ); - } else { - parser_display($1.special, - args.empty()? NULL : args.data(), args.size(), - DISPLAY_ADVANCE); - } - current.declaratives_evaluate(ec_none_e); - } - | disp_body NO ADVANCING end_display +display: disp_body end_display[advance] { - std::vector <cbl_refer_t> args($1.vargs->args.size()); - std::copy( $1.vargs->args.begin(), $1.vargs->args.end(), args.begin() ); - - if( $1.special && $1.special->id == ARG_NUM_e ) { - if( $1.vargs->args.size() != 1 ) { - error_msg(@1, "ARGUMENT-NUMBER can be set to only one value"); - } - cbl_refer_t& src( $1.vargs->args.front() ); - cbl_field_t *dst = register_find("_ARGI"); - parser_move( dst, src ); - } else { - parser_display($1.special, - args.empty()? NULL : args.data(), args.size(), - DISPLAY_NO_ADVANCE); - } - current.declaratives_evaluate(ec_none_e); + std::vector <cbl_refer_t> args($1.vargs->args.begin(), + $1.vargs->args.end()); + parser_display($1.special, args, $advance); + current.declaratives_evaluate(); } ; -end_display: %empty - | END_DISPLAY +end_display: %empty { $$ = DISPLAY_ADVANCE; } + | END_DISPLAY { $$ = DISPLAY_ADVANCE; } + | NO ADVANCING { $$ = DISPLAY_NO_ADVANCE; } + | NO ADVANCING END_DISPLAY { $$ = DISPLAY_NO_ADVANCE; } ; disp_body: disp_vargs[vargs] { $$.special = NULL; $$.vargs = $vargs; } - | disp_vargs[vargs] UPON disp_target[special] + | disp_vargs[vargs] UPON disp_upon[special] { $$.special = $special; $$.vargs = $vargs; @@ -5371,20 +5884,76 @@ 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. + // These may come through as a NAME, depending on how scanned. + int token = 0; + switch(*special_type) { + case ARG_NUM_e: token = ARGUMENT_NUMBER; break; + case ENV_NAME_e: token = ENVIRONMENT_NAME; break; + case ENV_VALUE_e: token = ENVIRONMENT_VALUE; break; + + case ARG_VALUE_e: + default: + error_msg(@NAME, "cannot DISPLAY UPON %qs", $NAME); + YYERROR; + break; + } + cbl_special_name_t special = { token, *special_type }; + namcpy(@NAME, special.name, $NAME); + + e = symbol_special_add(PROGRAM, &special); + } + $$ = cbl_special_name_of(e); + } + | ARGUMENT_NUMBER { + // Add the name now, as a convenience. + cbl_special_name_t special = + { ARGUMENT_NUMBER, ARG_NUM_e, "ARGUMENT-NUMBER" }; + symbol_elem_t *e = symbol_special_add(PROGRAM, &special); + $$ = cbl_special_name_of(e); + } + | ENVIRONMENT_NAME { + // Add the name now, as a convenience. + cbl_special_name_t special = + { ENVIRONMENT_NAME, ENV_NAME_e, "ENVIRONMENT-NAME" }; + symbol_elem_t *e = symbol_special_add(PROGRAM, &special); + $$ = cbl_special_name_of(e); + } + | ENVIRONMENT_VALUE { + // Add the name now, as a convenience. + cbl_special_name_t special = + { ENVIRONMENT_VALUE, ENV_VALUE_e, "ENVIRONMENT-VALUE" }; + symbol_elem_t *e = symbol_special_add(PROGRAM, &special); + $$ = cbl_special_name_of(e); } ; +exhibit_stmt: EXHIBIT exh_changed exh_named vargs { + statement_begin(@1, EXHIBIT); + std::vector<cbl_refer_t> args( $vargs->args.begin(), + $vargs->args.end() ); + parser_exhibit( $exh_changed, $exh_named, args ); + } + ; +exh_changed: %empty { $$ = false; } + | CHANGED { $$ = true; } + ; +exh_named: %empty { $$ = false; } + | NAMED { $$ = true; } + ; + divide: divide_impl end_divide { ast_divide($1); } | divide_cond end_divide { ast_divide($1); } ; @@ -5480,22 +6049,22 @@ end_program: end_program1[end] '.' gcc_unreachable(); } if( !matches ) { - error_msg(@end, "END %s %s' does not match IDENTIFICATION DIVISION '%s'", + error_msg($end.loc, "END %s %s does not match " + "%<IDENTIFICATION DIVISION %s%>", token_name, name, prog->name); YYERROR; } if( 0 != strcasecmp(prog->name, name) ) { - error_msg(@end, "END PROGRAM '%s' does not match PROGRAM-ID '%s'", + error_msg($end.loc, "END PROGRAM '%s' does not match PROGRAM-ID '%s'", name, prog->name); YYERROR; } std::set<std::string> externals = current.end_program(); if( !externals.empty() ) { - for( auto name : externals ) { - yywarn("%s calls external symbol '%s'", prog->name, name.c_str()); + for( const auto& name : externals ) { + dbgmsg("%s calls external symbol '%s'", prog->name, name.c_str()); } - YYERROR; } // pointer still valid because name is in symbol table ast_end_program(prog->name); @@ -5511,28 +6080,32 @@ end_program: end_program1[end] '.' token_name = "FUNCTION"; break; default: - cbl_internal_error( "END token invalid"); + cbl_internal_error( "%<END%> token invalid"); } - error_msg(@end, "END %s requires NAME before '.'", token_name); + error_msg(@end, "%<END%> %s requires %<NAME%> before %<.%>", token_name); YYERROR; } ; end_program1: END_PROGRAM namestr[name] { + $$.loc = @name; $$.token = END_PROGRAM; $$.name = $name; } | END_FUNCTION namestr[name] { + $$.loc = @name; $$.token = END_FUNCTION; $$.name = $name; } | END_PROGRAM '.' // error { + $$.loc = @1; $$.token = END_PROGRAM; } | END_FUNCTION '.' // error { + $$.loc = @1; $$.token = END_FUNCTION; } ; @@ -5587,7 +6160,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)) ); } @@ -5602,9 +6175,7 @@ exit_with: %empty } | RETURNING stop_status { - if( ! dialect_mf() ) { - dialect_error(@2, "RETURNING <number>", "mf"); - } + dialect_ok(@$, MfReturningNum, "RETURNING <number>"); $$ = $stop_status? $stop_status : new_reference(literally_one); } ; @@ -6171,17 +6742,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; @@ -6276,7 +6847,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, $$); } } @@ -6287,8 +6858,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; } } @@ -6324,14 +6895,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; } @@ -6351,13 +6922,13 @@ typename: NAME name: qname { build_symbol_map(); - auto namelocs( name_queue.pop() ); - auto names( name_queue.namelist_of(namelocs) ); - auto inner = namelocs.back(); + auto namelocs( name_queue.pop() ); + auto names( name_queue.namelist_of(namelocs) ); + auto inner = namelocs.back(); if( ($$ = field_find(names)) == NULL ) { if( procedure_div_e == current_division ) { - error_msg(inner.loc, - "DATA-ITEM '%s' not found", inner.name ); + error_msg(inner.loc, + "DATA-ITEM '%s' not found", inner.name ); YYERROR; } /* @@ -6368,9 +6939,9 @@ name: qname auto name = names.front(); names.pop_front(); auto e = symbol_field_forward_add(PROGRAM, parent, - name, yylineno); + name, @1.first_line); if( !e ) YYERROR; - symbol_field_location( symbol_index(e), @qname ); + symbol_field_location( symbol_index(e), @qname ); parent = symbol_index(e); $$ = cbl_field_of(e); } @@ -6398,10 +6969,16 @@ ctx_name: NAME context_word: APPLY { static char s[] ="APPLY"; $$ = s; } // screen description entry + | ARGUMENT_NUMBER { static char s[] ="ARGUMENT-NUMBER"; + $$ = s; } // Display Upon / Accept From + | ARGUMENT_VALUE { static char s[] ="ARGUMENT-VALUE"; + $$ = s; } // Accept From | ARITHMETIC { static char s[] ="ARITHMETIC"; $$ = s; } // OPTIONS paragraph | ATTRIBUTE { static char s[] ="ATTRIBUTE"; $$ = s; } // SET statement + | ATTRIBUTES { static char s[] ="ATTRIBUTES"; + $$ = s; } // XML GENERATE | AUTO { static char s[] ="AUTO"; $$ = s; } // screen description entry | AUTOMATIC { static char s[] ="AUTOMATIC"; @@ -6434,6 +7011,10 @@ context_word: APPLY { static char s[] ="APPLY"; $$ = s; } // ERASE clause in a screen description entry | ENTRY_CONVENTION { static char s[] ="ENTRY-CONVENTION"; $$ = s; } // OPTIONS paragraph + | ENVIRONMENT_NAME { static char s[] ="ENVIRONMENT-NAME"; + $$ = s; } // Display Upon + | ENVIRONMENT_VALUE { static char s[] ="ENVIRONMENT-VALUE"; + $$ = s; } // Display Upon / Accept From | ERASE { static char s[] ="ERASE"; $$ = s; } // screen description entry | EXPANDS { static char s[] ="EXPANDS"; @@ -6486,6 +7067,8 @@ context_word: APPLY { static char s[] ="APPLY"; $$ = s; } // LOCK MODE clause | MULTIPLE { static char s[] ="MULTIPLE"; $$ = s; } // LOCK ON phrase + | NAT { static char s[] ="NAT"; + $$ = s; } // CONVERT function | NEAREST_AWAY_FROM_ZERO { static char s[] ="NEAREST-AWAY-FROM-ZERO"; $$ = s; } // INTERMEDIATE ROUNDING clause and ROUNDED phrase | NEAREST_EVEN { static char s[] ="NEAREST-EVEN"; @@ -6522,7 +7105,7 @@ context_word: APPLY { static char s[] ="APPLY"; $$ = s; } // screen description entry | SHORT { static char s[] ="SHORT"; $$ = s; } // DYNAMIC LENGTH STRUCTURE clause - | SIGNED { static char s[] ="SIGNED"; + | SIGNED_kw { static char s[] ="SIGNED"; $$ = s; } // DYNAMIC LENGTH STRUCTURE clause and USAGE clause | STANDARD_BINARY { static char s[] ="STANDARD-BINARY"; $$ = s; } // ARITHMETIC clause @@ -6548,7 +7131,7 @@ context_word: APPLY { static char s[] ="APPLY"; $$ = s; } // ALPHABET clause | UNDERLINE { static char s[] ="UNDERLINE"; $$ = s; } // screen description entry and SET attribute statement - | UNSIGNED { static char s[] ="UNSIGNED"; + | UNSIGNED_kw { static char s[] ="UNSIGNED"; $$ = s; } // USAGE clause | UTF_8 { static char s[] ="UTF-8"; $$ = s; } // ALPHABET clause @@ -6564,7 +7147,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; } @@ -6627,8 +7210,9 @@ move: MOVE scalar TO move_tgts[tgts] } if( !move_corresponding(*$to, *$from) ) { - yywarn( "%s and %s have no corresponding fields", - $from->field->name, $to->field->name ); + cbl_message( @$, ParNoCorrespondingW, + "%s and %s have no corresponding fields", + $from->field->name, $to->field->name ); } } ; @@ -6652,10 +7236,18 @@ move_tgt: scalar[tgt] { const auto& field(*$1); static char buf[32]; const char *value_str( name_of($literal) ); - if( is_numeric($1) && - float(field.data.value_of()) == int(field.data.value_of()) ) { - sprintf(buf, "%d", int(field.data.value_of())); - value_str = buf; + if( is_numeric($1) ) + { + REAL_VALUE_TYPE val = TREE_REAL_CST (field.data.value_of()); + int ival = (int)real_to_integer (&val); + val = real_value_truncate (TYPE_MODE (float_type_node), + val); + REAL_VALUE_TYPE rival; + real_from_integer (&rival, VOIDmode, ival, SIGNED); + if( real_identical (&val, &rival) ) { + sprintf(buf, "%d", ival); + value_str = buf; + } } auto litcon = field.name[0] == '_'? "literal" : "constant"; error_msg(@literal, "%s is a %s", value_str, litcon); @@ -6774,9 +7366,9 @@ arith_err: SIZE_ERROR *ptgt = $1 == NOT? current.compute_not_error() : current.compute_on_error(); } else { - *ptgt = label_add(LblArith, uniq_label("arith"), yylineno); + *ptgt = label_add(LblArith, uniq_label("arith"), @1.first_line); } - (*ptgt)->lain = yylineno; + (*ptgt)->lain = @1.first_line; parser_arith_error( *ptgt ); } ; @@ -6797,7 +7389,7 @@ arith_err: SIZE_ERROR relop: '<' { $$ = '<'; } | LE { $$ = LE; } - | '=' { $$ = '='; } + | EQ { $$ = EQ; } | NE { $$ = NE; } | GE { $$ = GE; } | '>' { $$ = '>'; } @@ -6829,22 +7421,22 @@ 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(none_e) ); + dialect_ok(@1, IbmLengthOf, "LENGTH OF"); + parser_set_numeric($$->field, $size); + } | LENGTH_OF name[val] { location_set(@1); - $$ = new cbl_refer_t( new_tempnumeric() ); - $$->field->clear_attr(signable_e); - if( dialect_gcc() ) { - dialect_error(@1, "LENGTH OF", "ibm"); - } + $$ = new cbl_refer_t( new_tempnumeric(none_e) ); + dialect_ok(@1, IbmLengthOf, "LENGTH OF"); parser_set_numeric($$->field, $val->data.capacity); } | LENGTH_OF name[val] subscripts[subs] { location_set(@1); - $$ = new cbl_refer_t( new_tempnumeric() ); - $$->field->clear_attr(signable_e); - if( dialect_gcc() ) { - dialect_error(@1, "LENGTH OF", "ibm"); - } + $$ = new cbl_refer_t( new_tempnumeric(none_e) ); + dialect_ok(@1, IbmLengthOf, "LENGTH OF"); if( 0 == dimensions($val) ) { cbl_refer_t r1($val); subscript_dimension_error( @subs, $subs->refers.size(), &r1 ); @@ -6872,34 +7464,42 @@ num_value: scalar // might actually be a string /* cce_relexpr: cce_expr */ /* | cce_relexpr '<' cce_expr { $$ = $1 < $3; } */ /* | cce_relexpr LE cce_expr { $$ = $1 <= $3; } */ -/* | cce_relexpr '=' cce_expr { $$ = $1 == $3; } */ +/* | cce_relexpr EQ cce_expr { $$ = $1 == $3; } */ /* | cce_relexpr NE cce_expr { $$ = $1 != $3; } */ /* | cce_relexpr GE cce_expr { $$ = $1 >= $3; } */ /* | cce_relexpr '>' cce_expr { $$ = $1 > $3; } */ /* ; */ cce_expr: cce_factor - | cce_expr '+' cce_expr { $$ = $1 + $3; } - | cce_expr '-' cce_expr { $$ = $1 - $3; } - | cce_expr '*' cce_expr { $$ = $1 * $3; } - | cce_expr '/' cce_expr { $$ = $1 / $3; } + | cce_expr '+' cce_expr { + real_arithmetic (&$$, PLUS_EXPR, &$1, &$3); + real_convert (&$$, TYPE_MODE (float128_type_node), &$$); + } + | cce_expr '-' cce_expr { + real_arithmetic (&$$, MINUS_EXPR, &$1, &$3); + real_convert (&$$, TYPE_MODE (float128_type_node), &$$); + } + | cce_expr '*' cce_expr { + real_arithmetic (&$$, MULT_EXPR, &$1, &$3); + real_convert (&$$, TYPE_MODE (float128_type_node), &$$); + } + | cce_expr '/' cce_expr { + real_arithmetic (&$$, RDIV_EXPR, &$1, &$3); + real_convert (&$$, TYPE_MODE (float128_type_node), &$$); + } | '+' cce_expr %prec NEG { $$ = $2; } - | '-' cce_expr %prec NEG { $$ = -$2; } + | '-' cce_expr %prec NEG { $$ = real_value_negate (&$2); } | '(' cce_expr ')' { $$ = $2; } ; cce_factor: NUMSTR { - /* - * As of March 2023, glibc printf does not deal with - * __int128_t. The below assertion is not required. It - * serves only remind us we're far short of the precision - * required by ISO. - */ - static_assert( sizeof($$) == sizeof(_Float128), - "quadmath?" ); - static_assert( sizeof($$) == 16, - "long doubles?" ); - $$ = numstr2i($1.string, $1.radix); + /* real_from_string does not allow arbitrary radix. */ + // When DECIMAL IS COMMA, commas act as decimal points. + gcc_assert($1.radix == decimal_e); + auto p = $1.string, pend = p + strlen(p); + std::replace(p, pend, ',', '.'); + real_from_string3( &$$, $1.string, + TYPE_MODE (float128_type_node) ); } ; @@ -6929,11 +7529,19 @@ section_name: NAME section_kw '.' section_kw: SECTION { - if( $1 ) { + if( $1 && dialect_ok(@1, IbmSectionSegmentW, "SECTION segment") ) { + cbl_message(@1, IbmSectionSegmentW, + "SECTION segment %qs was ignored", $1); if( *$1 == '-' ) { - error_msg(@1, "SECTION segment %s is negative", $1); + cbl_message(@1, IbmSectionNegE, + "SECTION segment %qs is negative", $1); } else { - cbl_unimplementedw("SECTION segment %s was ignored", $1); + int sectno; + sscanf($1, "%d", §no); + if( ! (0 <= sectno && sectno <= 99) ) { + cbl_message(@1, IbmSectionRangeE, + "SECTION segment %qs must be 0-99", $1); + } } } } @@ -6951,10 +7559,7 @@ stop: STOP RUN exit_with | STOP NUMSTR[status] // IBM syntax { statement_begin(@1, STOP); - if( ! dialect_ibm() ) { - dialect_error(@2, "STOP <number> is not ISO syntax,", "ibm"); - YYERROR; - } + dialect_ok(@2, IbmStopNumber, "STOP <number>"); cbl_refer_t status( new_literal($status.string, $status.radix) ); parser_see_stop_run( status, NULL ); } @@ -6976,7 +7581,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(), @@ -6996,18 +7601,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 { @@ -7035,22 +7640,22 @@ 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(none_e); + dialect_ok(@1, IbmLengthOf, "LENGTH OF"); + parser_set_numeric($$, $size); + } | LENGTH_OF name[val] { location_set(@1); - $$ = new_tempnumeric(); - $$->clear_attr(signable_e); - if( dialect_gcc() ) { - dialect_error(@1, "LENGTH OF", "ibm"); - } + $$ = new_tempnumeric(none_e); + dialect_ok(@1, IbmLengthOf, "LENGTH OF"); parser_set_numeric($$, $val->data.capacity); } | LENGTH_OF name[val] subscripts[subs] { location_set(@1); - $$ = new_tempnumeric(); - $$->clear_attr(signable_e); - if( dialect_gcc() ) { - dialect_error(@1, "LENGTH OF", "ibm"); - } + $$ = new_tempnumeric(none_e); + dialect_ok(@1, IbmLengthOf, "LENGTH OF"); if( 0 == dimensions($val) ) { cbl_refer_t r1($val); subscript_dimension_error( @subs, $subs->refers.size(), &r1 ); @@ -7275,6 +7880,7 @@ perform_cond: UNTIL { parser_perform_conditional( &perform_current()->tgt); } perform_inline: perform_start statements END_PERFORM { location_set(@END_PERFORM); + parser_sleep(*cbl_refer_t::empty()); $$ = perform_current(); if( $perform_start == LOCATION ) { error_msg(@1, "LOCATION not valid with PERFORM Format 2"); @@ -7283,12 +7889,14 @@ perform_inline: perform_start statements END_PERFORM | perform_start END_PERFORM { location_set(@END_PERFORM); + parser_sleep(*cbl_refer_t::empty()); $$ = perform_current(); if( $perform_start == LOCATION ) { error_msg(@1, "LOCATION not valid with PERFORM Format 2"); } } ; + perform_start: %empty %prec LOCATION { perform_ec_setup(); $$ = 0; @@ -7315,18 +7923,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"); } ; @@ -7344,7 +7941,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); @@ -7434,12 +8031,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 { @@ -7448,12 +8045,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 { @@ -7462,18 +8059,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); } ; @@ -7564,9 +8161,10 @@ subtract_body: sum FROM rnames corresponding_arith_fields( $sum->refers.front().field, rhs.front().refer.field ); if( pairs.empty() ) { - yywarn( "%s and %s have no corresponding fields", - $sum->refers.front().field->name, - rhs.front().refer.field->name ); + cbl_message(ParNoCorrespondingW, + "%s and %s have no corresponding fields", + $sum->refers.front().field->name, + rhs.front().refer.field->name ); } // First src/tgt elements are templates. // Their subscripts apply to the correspondents. @@ -7604,22 +8202,22 @@ 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(none_e) ); + dialect_ok(@1, IbmLengthOf, "LENGTH OF"); + parser_set_numeric($$->field, $size); + } | LENGTH_OF name[val] { location_set(@1); - $$ = new cbl_refer_t( new_tempnumeric() ); - $$->field->clear_attr(signable_e); - if( dialect_gcc() ) { - dialect_error(@1, "LENGTH OF", "ibm"); - } + $$ = new cbl_refer_t( new_tempnumeric(none_e) ); + dialect_ok(@1, IbmLengthOf, "LENGTH OF"); parser_set_numeric($$->field, $val->size()); } | LENGTH_OF name[val] subscripts[subs] { location_set(@1); - $$ = new cbl_refer_t( new_tempnumeric() ); - $$->field->clear_attr(signable_e); - if( dialect_gcc() ) { - dialect_error(@1, "LENGTH OF", "ibm"); - } + $$ = new cbl_refer_t( new_tempnumeric(none_e) ); + dialect_ok(@1, IbmLengthOf, "LENGTH OF"); if( 0 == dimensions($val) ) { cbl_refer_t r1($val); subscript_dimension_error( @subs, $subs->refers.size(), &r1 ); @@ -7628,6 +8226,10 @@ varg1a: ADDRESS OF scalar { } ; +binary_type: BINARY_INTEGER { $$ = $1.capacity; } + | COMPUTATIONAL { $$ = $1.capacity; } + ; + literal: literalism { $$ = $1.isymbol()? @@ -7671,14 +8273,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); } ; @@ -7738,10 +8340,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; @@ -7752,7 +8350,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; } @@ -7865,7 +8463,7 @@ read_key: %empty { $$ = new cbl_refer_t(); } write: write_file { - current.declaratives_evaluate( $1.file, $1.handled ); + current.declaratives_evaluate($1.file ); } ; @@ -7985,7 +8583,7 @@ advance_by: scalar lines { $$ = $1; } /* BUG: should accept reference */ * number of lines is negative. So, we use the * negative Number Of The Beast as a PAGE flag. */ - $$ = new_reference( new_literal("-666") ); + $$ = new_reference( new_literal(xstrdup("-666")) ); } | device_name { $$ = new_reference(literally_one); } ; @@ -8042,7 +8640,33 @@ io_invalid: INVALID key { delete: delete_impl end_delete | delete_cond end_delete + | delete_file end_delete + ; +delete_file: DELETE delete_file_body[stmt] delete_error[err] { + if( ! $err.on_error ) parser_file_delete_on_exception($stmt); + if( ! $err.not_error ) parser_file_delete_not_exception($stmt); + parser_file_delete_end($stmt); + current.declaratives_evaluate(); + } +delete_file_body: + FILE_KW override filenames retry_phrase { + $$ = label_add(@$, LblXml, uniq_label("xfile")); + xml_statements.push($$); + statement_begin(@$, DELETE); + std::vector<cbl_file_t*> + filenames($filenames->files.begin(), + $filenames->files.end() ); + parser_file_delete_file( $$, filenames); + } ; +retry_phrase: %empty + | RETRY expr TIMES + | FOR expr SECONDS + | FOREVER { + cbl_unimplemented("DELETE FILE RETRY"); + } + ; + delete_impl: DELETE delete_body[file] { file_delete_args.call_parser_file_delete(true); @@ -8075,13 +8699,70 @@ delete_body: filename[file] record $$ = $file; } ; + +delete_error: %empty %prec DELETE { + $$.on_error = $$.not_error = nullptr; + } + | delete_excepts %prec DELETE + ; +delete_excepts: delete_except[a] statements %prec DELETE + { + assert( $a.on_error || $a.not_error ); + assert( ! ($a.on_error && $a.not_error) ); + $$ = $a; + } + | delete_excepts[a] delete_except[b] statements %prec DELETE + { + if( $a.on_error && $a.not_error ) { + error_msg(@1, "too many ON ERROR clauses"); + YYERROR; + } + // "ON" and "NOT ON" could be reversed, but not duplicated. + if( $a.on_error && $b.on_error ) { + error_msg(@1, "duplicate ON ERROR clauses"); + YYERROR; + } + if( $a.not_error && $b.not_error ) { + error_msg(@1, "duplicate NOT ON ERROR clauses"); + YYERROR; + } + $$ = $a; + if( $$.on_error ) { + assert($b.not_error); + $$.not_error = $b.not_error; + } else { + assert($b.on_error); + $$.on_error = $b.on_error; + } + } + ; +delete_except: EXCEPTION + { + auto xml_stmt = xml_statements.top(); + // The value of the pointer no longer matters, only NULL or not. + $$.on_error = $$.not_error = nullptr; + switch($1) { + case EXCEPTION: + $$.on_error = xml_stmt; + parser_file_delete_on_exception(xml_stmt); + break; + case NOT: + $$.not_error = xml_stmt; + parser_file_delete_not_exception(xml_stmt); + break; + default: + gcc_unreachable(); + } + } + ; + end_delete: %empty %prec DELETE | END_DELETE ; rewrite: rewrite1 { - current.declaratives_evaluate($1.file, $1.handled); + current.declaratives_evaluate($1.file); } ; @@ -8122,12 +8803,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 @@ -8137,7 +8827,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] @@ -8147,30 +8837,27 @@ start_body: filename[file] int size = key == 0 ? 0 : $file->keys[key - 1].size(); auto ksize = new_tempnumeric(); parser_set_numeric(ksize, size); - if( yydebug ) { - yywarn("START: key #%d '%s' has size %d", - key, $key->name, size); - } - file_start_args.init(@file, $file); + dbgmsg("START: key #%d '%s' has size %d", key, $key->name, size); + $$ = 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 ); } ; @@ -8180,8 +8867,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(); @@ -8200,8 +8887,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 ); @@ -8324,6 +9010,24 @@ set: SET set_tgts[tgts] TO set_operand[src] new_literal($src, quoted_e); ast_set_pointers($tgts->targets, literal); } + // Format 12 (save-locale): + | SET set_tgts[tgts] TO LOCALE locale_current + { + if( $tgts->targets.size() > 1 ) { + error_msg(@tgts, "only 1 save-locale data-item is valid"); + } + switch($locale_current) { + case LC_ALL_kw: + case DEFAULT: + ast_save_locale($tgts->targets.front().refer, $locale_current); + break; + default: + gcc_unreachable(); + } + cbl_unimplementedw(SynSetToLocale, + "unimplemented: %<SET ... TO LOCALE%>"); + } + ; | SET set_tgts[tgts] UP BY num_operand[src] { statement_begin(@1, SET); @@ -8367,7 +9071,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)); @@ -8382,6 +9086,43 @@ set: SET set_tgts[tgts] TO set_operand[src] set_conditional($yn)); } | SET { statement_begin(@1, SET); } many_switches + + // Format 11 (set-locale): + | SET LOCALE locale_tgt[tgt] TO locale_src + { + if( $tgt->is_default() ) { + // do something $tgt->default_of() + } else { + // do something $tgt->lc_categories() + } + cbl_unimplementedw(SynSetLocaleTo, + "unimplemented: %<SET LOCALE ... TO%>"); + } + ; + +locale_tgt: user_default { $$ = new locale_tgt_t(); *$$ = $1; } + | loc_categories + ; +loc_categories: loc_category { $$ = new locale_tgt_t($1); } + | loc_categories loc_category { + $$ = $1; + $$->push_back($2); + } + ; +loc_category: LC_ALL_kw { $$ = LC_ALL_kw; } + | LC_COLLATE_kw { $$ = LC_COLLATE_kw; } + | LC_CTYPE_kw { $$ = LC_CTYPE_kw; } + | LC_MESSAGES_kw { $$ = LC_MESSAGES_kw; } + | LC_MONETARY_kw { $$ = LC_MONETARY_kw; } + | LC_NUMERIC_kw { $$ = LC_NUMERIC_kw; } + | LC_TIME_kw { $$ = LC_TIME_kw; } + ; +locale_src: scalar + | DEFAULT { assert($1 == 'U' || $1 == 'S'); } + ; + +locale_current: LC_ALL_kw { $$ = LC_ALL_kw; } // locale to be saved by SET Format 12. + | user_default { $$ = DEFAULT; } ; many_switches: set_switches @@ -8392,7 +9133,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 @@ -8447,12 +9188,12 @@ search_1_body: name[table] search_varying[varying] cbl_name_t label_name; auto len = snprintf(label_name, sizeof(label_name), - "linear_search_%d", yylineno); + "linear_search_%d", @1.first_line); if( ! (0 < len && len < int(sizeof(label_name))) ) { gcc_unreachable(); } cbl_label_t *name = label_add( LblSearch, - label_name, yylineno ); + label_name, @1.first_line ); auto varying($varying); if( index == varying ) varying = NULL; parser_lsearch_start( name, $table, index, varying ); @@ -8476,7 +9217,7 @@ search_1_cases: search_1_case lookahead = keyword_str(yychar); } } - yywarn("Just one case, lookahead is '%s'", lookahead); + dbgmsg("Just one case, lookahead is '%s'", lookahead); } } | search_1_cases search_1_case @@ -8505,9 +9246,9 @@ search_binary: SEARCH ALL search_2_body search_2_cases search_2_body: name[table] { statement_begin(@$, SEARCH); - char *label_name = xasprintf("binary_search_%d", yylineno); + char *label_name = xasprintf("binary_search_%d", @1.first_line); cbl_label_t *name = label_add( LblSearch, - label_name, yylineno ); + label_name, @1.first_line ); parser_bsearch_start( name, $table ); search_alloc(name); } @@ -8530,16 +9271,16 @@ search_stmts: statements %prec ADD search_terms: search_term | search_terms AND search_term ; -search_term: scalar[key] '=' search_expr[sarg] +search_term: scalar[key] EQ 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; } @@ -8578,8 +9319,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); @@ -8589,9 +9329,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 ); } ; @@ -8632,7 +9373,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 ); @@ -8716,16 +9457,20 @@ sort_target: label_name release: RELEASE NAME[record] FROM scalar[name] { - statement_begin(@1, RELEASE); - symbol_elem_t *record = symbol_find(@record, $record); - parser_move(cbl_field_of(record), *$name); - parser_release(cbl_field_of(record)); + if( ! mode_syntax_only() ) { + statement_begin(@1, RELEASE); + symbol_elem_t *record = symbol_find(@record, $record); + parser_move(cbl_field_of(record), *$name); + parser_release(cbl_field_of(record)); + } } | RELEASE NAME[record] { - statement_begin(@1, RELEASE); - symbol_elem_t *record = symbol_find(@record, $record); - parser_release(cbl_field_of(record)); + if( ! mode_syntax_only() ) { + statement_begin(@1, RELEASE); + symbol_elem_t *record = symbol_find(@record, $record); + parser_release(cbl_field_of(record)); + } } ; @@ -8824,7 +9569,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 { @@ -8836,8 +9581,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 { @@ -8848,11 +9593,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; @@ -8866,6 +9611,22 @@ 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 ) { + // Make a copy of replace, because nice_name returns a static + char *replace_name = xstrdup(nice_name_of(replace)); + error_msg(@match, "%qs, size %u NOT EQUAL %qs, size %u", + nice_name_of(match), match->data.capacity, + replace_name, replace->data.capacity); + free(replace_name); + YYERROR; + } + } + } } if( is_constant($inspected->field) ) { auto name = nice_name_of($inspected->field); @@ -8885,7 +9646,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 { @@ -8895,12 +9656,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"); @@ -8912,44 +9678,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; @@ -8962,32 +9721,27 @@ tally_forth: CHARACTERS insp_mtquals[q] scalar[next_tally] | TRAILING tally_matches[q] { $q->bound = bound_trailing_e; $$ = $q; - if( ! dialect_mf() ) { - dialect_error(@1, "TRAILING", "mf"); - } + dialect_ok(@1, MfTrailing, "TRAILING"); } ; -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); } ; @@ -9017,13 +9771,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 @@ -9031,9 +9785,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) ); @@ -9047,21 +9801,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 { @@ -9071,6 +9826,7 @@ insp_quals: insp_qual { } else { $$->after = *$insp_qual.qual; } + dump_inspect_match(*$$); } | insp_quals insp_qual { @@ -9096,9 +9852,7 @@ first_leading: FIRST { $$ = bound_first_e; } | ALL { $$ = bound_all_e; } | LEADING { $$ = bound_leading_e; } | TRAILING { $$ = bound_trailing_e; - if( ! dialect_mf() ) { - dialect_error(@1, "TRAILING", "mf"); - } + dialect_ok(@1, MfTrailing, "TRAILING"); } ; @@ -9230,7 +9984,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, @@ -9247,15 +10001,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 @@ -9290,9 +10042,7 @@ call_body: ffi_name ; call_returning: RETURNING | GIVING { - if( !dialect_mf() ) { - dialect_error(@1, "CALL ... GIVING", "mf"); - } + dialect_ok(@1, MfCallGiving, "CALL ... GIVING"); } ; @@ -9332,7 +10082,12 @@ ffi_name: scalar $$->field = new_literal(strlen(L.name), L.name, quoted_e); } } - | LITERAL { $$ = new_reference(new_literal($1, quoted_e)); } + | LITERAL + { + // Pretend hex-encoded because that means use verbatim. + auto attr = cbl_field_attr_t(quoted_e | hex_encoded_e); + $$ = new_reference(new_literal($1, attr)); + } ; parameters: parameter { $$ = new ffi_args_t($1); } @@ -9444,7 +10199,7 @@ call_except: EXCEPTION { $$.not_error = NULL; $$.on_error = label_add(LblArith, - uniq_label("call"), yylineno); + uniq_label("call"), @1.first_line); if( !$$.on_error ) YYERROR; parser_call_exception( $$.on_error ); @@ -9453,15 +10208,15 @@ call_except: EXCEPTION std::swap($$.on_error, $$.not_error); } } - | OVERFLOW + | OVERFLOW_kw { $$.not_error = NULL; $$.on_error = label_add(LblArith, - uniq_label("call"), yylineno); + uniq_label("call"), @1.first_line); if( !$$.on_error ) YYERROR; parser_call_exception( $$.on_error ); - assert( $1 == OVERFLOW || $1 == NOT ); + assert( $1 == OVERFLOW_kw || $1 == NOT ); if( $1 == NOT ) { std::swap($$.on_error, $$.not_error); } @@ -9492,7 +10247,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); } @@ -9513,7 +10268,7 @@ go_to: GOTO labels[args] } for( auto& label : $args->elems ) { - label->used = yylineno; + label->used = @2.first_line; } cbl_label_t *arg = $args->elems.front(); parser_goto( cbl_refer_t(), 1, &arg ); @@ -9525,7 +10280,7 @@ go_to: GOTO labels[args] std::vector <cbl_label_t *> args($args->elems.size()); std::copy($args->elems.begin(), $args->elems.end(), args.begin()); for( auto& label : $args->elems ) { - label->used = yylineno; + label->used = @2.first_line; } parser_goto( *$value, args.size(), args.data() ); } @@ -9539,13 +10294,15 @@ go_to: GOTO labels[args] resume: RESUME NEXT STATEMENT { statement_begin(@1, RESUME); + dialect_not_ok( @1, IsoResume, "RESUME"); parser_clear_exception(); } | RESUME label_1[tgt] { statement_begin(@1, RESUME); + dialect_not_ok( @1, IsoResume, "RESUME"); parser_clear_exception(); - $tgt->used = yylineno; + $tgt->used = @1.first_line; parser_goto( cbl_refer_t(), 1, &$tgt ); } ; @@ -9595,14 +10352,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 @@ -9716,15 +10473,15 @@ on_overflows: on_overflow[over] statements %prec ADD } ; -on_overflow: OVERFLOW +on_overflow: OVERFLOW_kw { $$.not_error = NULL; $$.on_error = label_add(LblString, - uniq_label("string"), yylineno); + uniq_label("string"), @1.first_line); if( !$$.on_error ) YYERROR; parser_string_overflow( $$.on_error ); - assert( $1 == OVERFLOW || $1 == NOT ); + assert( $1 == OVERFLOW_kw || $1 == NOT ); if( $1 == NOT ) { std::swap($$.on_error, $$.not_error); } @@ -9741,14 +10498,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(); } ; @@ -9883,18 +10640,22 @@ 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); return actual; } ); - auto name = new_literal(strlen(L->name), L->name, quoted_e); + // Pretend hex-encoded because that means use verbatim. + auto attr = cbl_field_attr_t(quoted_e | hex_encoded_e); + auto name = new_literal(strlen(L->name), L->name, attr); ast_call( @1, name, $$, args.size(), args.data(), NULL, NULL, true ); } | FUNCTION_UDF_0 { @@ -9902,9 +10663,13 @@ 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); + // Pretend hex-encoded because that means use verbatim. + auto attr = cbl_field_attr_t(quoted_e | hex_encoded_e); + auto name = new_literal(strlen(L->name), L->name, attr); ast_call( @1, name, $$, narg, args, NULL, NULL, true ); } ; @@ -9923,7 +10688,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 @@ -9936,90 +10700,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')", - keyword_str($1), p - args.data(), name_of(p->field) ); + error_msg(loc, "FUNCTION %qs has " + "inconsistent parameter type %ld (%qs)", + keyword_str($1), (long)(p - args.data()), name_of(p->field) ); YYERROR; } $$ = is_numeric(args[0].field)? new_tempnumeric_float() : - new_alphanumeric(args[0].field->data.capacity); - + 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(8 * $r1->field->data.capacity); + $$ = 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); - uint32_t len = $r1->field->data.capacity; - $$ = new_alphanumeric(4 * len); + $$ = new_alphanumeric("DISPLAY-OF"); if( ! intrinsic_call_2($$, DISPLAY_OF, $r1, NULL) ) YYERROR; } | DISPLAY_OF '(' varg[r1] varg[r2] ')' { location_set(@1); - uint32_t len = $r1->field->data.capacity - + $r2->field->data.capacity; - $$ = new_alphanumeric(4 * len); + $$ = new_alphanumeric("DISPLAY-OF"); if( ! intrinsic_call_2($$, DISPLAY_OF, $r1, $r2) ) YYERROR; } | EXCEPTION_FILE filename { location_set(@1); - $$ = new_alphanumeric(256); + $$ = new_alphanumeric("EXCEPTION-FILE"); parser_exception_file( $$, $filename ); } | FIND_STRING '(' varg[r1] last start_after anycase ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = 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; } @@ -10028,7 +10793,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, @@ -10037,7 +10802,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; @@ -10048,14 +10813,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, @@ -10063,21 +10828,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; @@ -10085,14 +10850,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; @@ -10100,14 +10865,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; @@ -10115,7 +10880,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; @@ -10123,85 +10888,83 @@ intrinsic: function_udf | HEX_OF '(' varg[r1] ')' { location_set(@1); - $$ = new_alphanumeric(2 * $r1->field->data.capacity); + $$ = new_alphanumeric("HEX-OF"); if( ! intrinsic_call_1($$, HEX_OF, $r1, @r1)) YYERROR; } | LENGTH '(' tableish[val] ')' { location_set(@1); - $$ = new_tempnumeric(); - $$->clear_attr(signable_e); + $$ = new_tempnumeric("LENGTH", none_e); parser_set_numeric($$, $val->field->size()); if( ! intrinsic_call_1($$, LENGTH, $val, @val)) YYERROR; } | LENGTH '(' varg1a[val] ')' { location_set(@1); - $$ = new_tempnumeric(); - $$->clear_attr(signable_e); + $$ = new_tempnumeric("LENGTH", none_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", none_e); 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(64); + $$ = new_alphanumeric("SUBSTITUTE"); std::vector <cbl_substitute_t> args($inputs->size()); std::transform( $inputs->begin(), $inputs->end(), args.begin(), []( const substitution_t& arg ) { @@ -10217,7 +10980,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 ); } @@ -10244,14 +11007,14 @@ intrinsic: function_udf YYERROR; break; } - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = 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(32); // how long? + $$ = new_alphanumeric("USUBSTR"); if( ! intrinsic_call_3($$, FORMATTED_DATETIME, $r1, $r2, $r3) ) YYERROR; } @@ -10259,14 +11022,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; } @@ -10276,30 +11039,20 @@ intrinsic: function_udf auto type = intrinsic_return_type($1); switch(type) { case FldAlphanumeric: - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = 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) ) { - _Float128 output __attribute__ ((__unused__)); + if( is_literal($r1->field) && ! is_numeric($r1->field->type) ) { + // The parameter might be literal, but could be "hello". auto input = $r1->field->data.initial; - auto local = xstrdup(input), pend = local; - std::replace(local, local + strlen(local), ',', '.'); - std::remove_if(local, local + strlen(local), isspace); - output = strtof128(local, &pend); - // bad if strtof128 could not convert input - if( *pend != '\0' ) { - error_msg(@r1, "'%s' is not a numeric string", input); - } + error_msg(@r1, "'%s' is not a numeric literal", input); } } if( ! intrinsic_call_1($$, $1, $r1, @r1)) YYERROR; @@ -10308,7 +11061,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; } @@ -10319,12 +11072,12 @@ intrinsic: function_udf static auto one = new cbl_refer_t( new_literal("1") ); static auto four = new cbl_refer_t( new_literal("4") ); cbl_span_t year(one, four); - auto r3 = new_reference(new_alphanumeric(21)); + auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE)); r3->refmod = year; 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; } @@ -10335,12 +11088,12 @@ intrinsic: function_udf static auto one = new cbl_refer_t( new_literal("1") ); static auto four = new cbl_refer_t( new_literal("4") ); cbl_span_t year(one, four); - auto r3 = new_reference(new_alphanumeric(21)); + auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE)); r3->refmod = year; 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; } @@ -10349,7 +11102,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; } @@ -10361,12 +11114,12 @@ intrinsic: function_udf static auto one = new cbl_refer_t( new_literal("1") ); static auto four = new cbl_refer_t( new_literal("4") ); cbl_span_t year(one, four); - auto r3 = new_reference(new_alphanumeric(21)); + auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE)); r3->refmod = year; 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; } @@ -10377,12 +11130,12 @@ intrinsic: function_udf static auto one = new cbl_refer_t( new_literal("1") ); static auto four = new cbl_refer_t( new_literal("4") ); cbl_span_t year(one, four); - auto r3 = new_reference(new_alphanumeric(21)); + auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE)); r3->refmod = year; 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; } @@ -10391,7 +11144,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; } @@ -10403,12 +11156,12 @@ intrinsic: function_udf static auto one = new cbl_refer_t( new_literal("1") ); static auto four = new cbl_refer_t( new_literal("4") ); cbl_span_t year(one, four); - auto r3 = new_reference(new_alphanumeric(21)); + auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE)); r3->refmod = year; 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; } @@ -10419,12 +11172,12 @@ intrinsic: function_udf static auto one = new cbl_refer_t( new_literal("1") ); static auto four = new cbl_refer_t( new_literal("4") ); cbl_span_t year(one, four); - auto r3 = new_reference(new_alphanumeric(21)); + auto r3 = new_reference(new_alphanumeric(MAXLENGTH_CALENDAR_DATE)); r3->refmod = year; 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; } @@ -10433,7 +11186,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; } @@ -10441,25 +11194,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($r1->field->data.capacity); + $$ = new_alphanumeric(keyword_str($1)); if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR; } | intrinsic_locale @@ -10490,7 +11243,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; } ; @@ -10503,58 +11256,71 @@ subst_input: anycase first_last varg[v1] varg[v2] { } ; +locale_name: NAME + { + auto e = symbol_locale(PROGRAM, $NAME); + if( !e ) { + error_msg(@NAME, "no such SPECIAL-NAMES LOCALE: %qs", $NAME); + YYERROR; + } + $$ = const_cast<char*>( + __gg__encoding_iconv_name(cbl_locale_of(e)->encoding) ); + } + ; + intrinsic_locale: LOCALE_COMPARE '(' varg[r1] varg[r2] ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); cbl_refer_t dummy = {}; if( ! intrinsic_call_3($$, LOCALE_COMPARE, $r1, $r2, &dummy) ) YYERROR; } - | LOCALE_COMPARE '(' varg[r1] varg[r2] varg[r3] ')' + | LOCALE_COMPARE '(' varg[r1] varg[r2] locale_name ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); - if( ! intrinsic_call_3($$, LOCALE_COMPARE, $r1, $r2, $r3) ) YYERROR; + $$ = new_alphanumeric(); + cbl_refer_t locale(new_literal($locale_name)); + if( ! intrinsic_call_3($$, LOCALE_COMPARE, $r1, $r2, &locale) ) YYERROR; } | LOCALE_DATE '(' varg[r1] ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); cbl_refer_t dummy = {}; if( ! intrinsic_call_2($$, LOCALE_DATE, $r1, &dummy) ) YYERROR; } | LOCALE_DATE '(' varg[r1] varg[r2] ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); if( ! intrinsic_call_2($$, LOCALE_DATE, $r1, $r2) ) YYERROR; } | LOCALE_TIME '(' varg[r1] ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); cbl_refer_t dummy = {}; if( ! intrinsic_call_2($$, LOCALE_TIME, $r1, &dummy) ) YYERROR; } | LOCALE_TIME '(' varg[r1] varg[r2] ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); if( ! intrinsic_call_2($$, LOCALE_TIME, $r1, $r2) ) YYERROR; } | LOCALE_TIME_FROM_SECONDS '(' varg[r1] ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); cbl_refer_t dummy = {}; if( ! intrinsic_call_2($$, LOCALE_TIME_FROM_SECONDS, $r1, &dummy) ) YYERROR; } | LOCALE_TIME_FROM_SECONDS '(' varg[r1] varg[r2] ')' { location_set(@1); - $$ = new_alphanumeric($r1->field->data.capacity); + $$ = new_alphanumeric(); if( ! intrinsic_call_2($$, LOCALE_TIME_FROM_SECONDS, $r1, $r2) ) YYERROR; } ; @@ -10570,65 +11336,66 @@ trim_trailing: %empty { $$ = new_literal("0"); } // Remove both intrinsic0: CURRENT_DATE { location_set(@1); - $$ = new_alphanumeric(21); + $$ = 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(256); + $$ = new_alphanumeric("EXCEPTION-FILE-N"); intrinsic_call_0( $$, EXCEPTION_FILE_N ); } | EXCEPTION_FILE { location_set(@1); - $$ = new_alphanumeric(256); + $$ = new_alphanumeric("EXCEPTION-FILE"); parser_exception_file( $$ ); } | EXCEPTION_LOCATION_N { location_set(@1); - $$ = new_alphanumeric(256); + $$ = new_alphanumeric("EXCEPTION-LOCATION-N"); intrinsic_call_0( $$, EXCEPTION_LOCATION_N ); } | EXCEPTION_LOCATION { location_set(@1); - $$ = new_alphanumeric(256); + $$ = new_alphanumeric("EXCEPTION-LOCATION"); intrinsic_call_0( $$, EXCEPTION_LOCATION ); } | EXCEPTION_STATEMENT { location_set(@1); - $$ = new_alphanumeric(63); + $$ = new_alphanumeric("EXCEPTION-STATEMENT"); intrinsic_call_0( $$, EXCEPTION_STATEMENT ); } | EXCEPTION_STATUS { location_set(@1); - $$ = new_alphanumeric(31); + $$ = 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(32); // don't know correct size + $$ = new_alphanumeric("UUID4"); parser_intrinsic_call_0( $$, "__gg__uuid4" ); } | WHEN_COMPILED { location_set(@1); - $$ = new_alphanumeric(21); // Returns YYYYMMDDhhmmssss-0500 + // Returns YYYYMMDDhhmmssss-0500) + $$ = new_alphanumeric(MAXLENGTH_CALENDAR_DATE, "WHEN-COMPILED"); parser_intrinsic_call_0( $$, "__gg__when_compiled" ); } ; @@ -10767,6 +11534,10 @@ first_last: %empty { $$ = 0; } | LAST { $$ = 'L'; } ; +for: %empty + | FOR + ; + is_global: %empty %prec GLOBAL { $$ = false; } | is GLOBAL { $$ = true; } ; @@ -10816,6 +11587,10 @@ optional: %empty { $$ = false; } | OPTIONAL { $$ = true; } ; +override: %empty { $$ = false; } + | OVERRIDE { $$ = true; } + ; + program_kw: %empty | PROGRAM_kw ; @@ -10832,6 +11607,11 @@ sign: %empty | SIGN ; +is_signed: %empty { $$ = true; } + | SIGNED_kw { $$ = true; } + | UNSIGNED_kw { $$ = false; } + ; + start_after: %empty %prec AFTER | START AFTER varg ; @@ -10859,6 +11639,20 @@ usage: %empty | USAGE IS ; +user_default: DEFAULT + { // cannot be empty + switch( $1 ) { + case 'U': break; + case 'S': + error_msg(@1, "invalid syntax: SYSTEM-DEFAULT"); + break; + default: + error_msg(@1, "invalid syntax: DEFAULT"); + gcc_unreachable(); + } + } + ; + with: %empty | WITH ; @@ -10880,7 +11674,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"); @@ -10898,12 +11697,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; @@ -10915,8 +11713,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); } @@ -10929,12 +11727,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; @@ -11019,7 +11817,209 @@ cdf_none: ENTER | SERVICE_RELOAD ; +xmlgenerate: xmlgen_impl end_xml { + cbl_unimplemented("XML GENERATE"); + } + | xmlgen_cond end_xml { + cbl_unimplemented("XML GENERATE"); + } + ; +xmlgen_impl: + XMLGENERATE xmlgen_body + ; +xmlgen_cond: XMLGENERATE xmlgen_body[body] xmlexcepts[err] + ; + +xmlgen_body: XMLGENERATE name[id1] FROM name[id2] + xmlgen_count xmlencoding xmlgen_decl xmlgen_namespace + xmlgen_nameof xmlgen_typeof xmlgen_suppress + ; + +xmlgen_count: %empty + | COUNT in name[id3] + ; +xmlgen_decl: %empty + | with XML_DECLARATION with ATTRIBUTES + ; +xmlgen_namespace: + %empty + | NAMESPACE is name[id4] namespace_prefix + ; +namespace_prefix: + %empty + | NAMESPACE_PREFIX is namestr[id5] + ; +xmlgen_nameof: %empty + | NAME of xmlgen_ids + ; +xmlgen_ids: xmlgen_id + | xmlgen_ids xmlgen_id + ; +xmlgen_id: name[id6] is LITERAL[lit] + ; + +xmlgen_typeof: %empty + | TYPE of xmlgen_types + ; +xmlgen_types: xmlgen_type + | xmlgen_types xmlgen_type + ; +xmlgen_type: name[id6] is xmlgen_eltype + ; +xmlgen_eltype: ATTRIBUTE + | ELEMENT + | CONTENT + ; + +xmlgen_suppress: + %empty + | SUPPRESS xml_suppressions + ; +xml_suppressions: + xml_suppression + | xml_suppressions xml_suppression + ; +xml_suppression: + name[id8] xml_when_phrase + | xml_generic_suppression xml_when_figs + ; +xml_when_phrase: + %empty %prec ZERO + | xml_when_figs + ; +xml_when_figs: xml_when_fig + | xml_when_figs OR xml_when_fig + ; +xml_when_fig: ZERO + | SPACES + | LOW_VALUES + | HIGH_VALUES + ; +xml_generic_suppression: + %empty + | EVERY xml_generic_numeric xmlgen_eltype + ; +xml_generic_numeric: + %empty + | NUMERIC + | NONNUMERIC + ; + +xmlparse: xmlparse_impl end_xml { + auto xml_stmt = xml_statements.top(); + parser_xml_end(xml_stmt); + xml_statements.pop(); + current.declaratives_evaluate(); + } + | xmlparse_cond end_xml { + auto xml_stmt = xml_statements.top(); + parser_xml_end(xml_stmt); + xml_statements.pop(); + current.declaratives_evaluate(); + } + ; +xmlparse_impl: XMLPARSE xmlparse_body[body] + { + parser_xml_on_exception($body); + parser_xml_not_exception($body); + } + ; +xmlparse_cond: XMLPARSE xmlparse_body[body] xmlexcepts[err] + { + if( ! $err.on_error ) parser_xml_on_exception($body); + if( ! $err.not_error ) parser_xml_not_exception($body); + } + ; + +xmlparse_body: scalar xmlencoding xmlreturning xmlvalidating + PROCESSING PROCEDURE is xmlprocs[procs] + { + $$ = label_add(@$, LblXml, uniq_label("xml")); + xml_statements.push($$); + statement_begin(@$, XMLPARSE); + parser_xml_parse( $$, + *$scalar, + $xmlencoding, + $xmlvalidating, + $xmlreturning == NATIONAL, + $procs.from, + $procs.to ); + } + ; +xmlencoding: %empty %prec NAME { $$ = nullptr; } + | with ENCODING name [codepage] { $$ = $codepage; } + ; + +xmlreturning: %empty { $$ = 0; } + | RETURNING NATIONAL { $$ = NATIONAL; } + ; +xmlvalidating: %empty { $$ = nullptr; } + | VALIDATING with name { $$ = $name; } + | VALIDATING with FILE_KW name { $$ = $name; } + ; +xmlprocs: label_1 { + $$ = label_pair_t{$1}; + } + | label_1[from] THRU label_1[to] { + $$ = label_pair_t{$from, $to}; + } + ; + +xmlexcepts: xmlexcept[a] statements %prec XMLPARSE + { + assert( $a.on_error || $a.not_error ); + assert( ! ($a.on_error && $a.not_error) ); + $$ = $a; + } + | xmlexcepts[a] xmlexcept[b] statements %prec XMLPARSE + { + if( $a.on_error && $a.not_error ) { + error_msg(@1, "too many ON ERROR clauses"); + YYERROR; + } + // "ON" and "NOT ON" could be reversed, but not duplicated. + if( $a.on_error && $b.on_error ) { + error_msg(@1, "duplicate ON ERROR clauses"); + YYERROR; + } + if( $a.not_error && $b.not_error ) { + error_msg(@1, "duplicate NOT ON ERROR clauses"); + YYERROR; + } + $$ = $a; + if( $$.on_error ) { + assert($b.not_error); + $$.not_error = $b.not_error; + } else { + assert($b.on_error); + $$.on_error = $b.on_error; + } + } + ; +xmlexcept: EXCEPTION + { + auto xml_stmt = xml_statements.top(); + // The value of the pointer no longer matters, only NULL or not. + $$.on_error = $$.not_error = nullptr; + switch($1) { + case EXCEPTION: + $$.on_error = xml_stmt; + parser_xml_on_exception(xml_stmt); + break; + case NOT: + $$.not_error = xml_stmt; + parser_xml_not_exception(xml_stmt); + break; + default: + gcc_unreachable(); + } + } + ; + +end_xml: %empty %prec XMLPARSE + | END_XML %prec XMLPARSE + ; %% static YYLTYPE @@ -11029,60 +12029,93 @@ 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, bool is_function) { if( is_literal(name.field) ) { - cbl_field_t called = { 0, FldLiteralA, FldInvalid, quoted_e | constant_e, - 0, 0, 77, nonarray, 0, "", - 0, cbl_field_t::linkage_t(), {}, NULL }; + cbl_field_t called = { FldLiteralA, quoted_e | constant_e, + name.field->data, 77 }; + called.attr |= name.field->attr; snprintf(called.name, sizeof(called.name), "_%s", name.field->data.initial); - called.data = name.field->data; + called.attr |= name.field->attr; name.field = cbl_field_of(symbol_field_add(PROGRAM, &called)); symbol_field_location(field_index(name.field), loc); 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() { + cbl_enabled_exceptions_t& enabled_exceptions( cdf_enabled_exceptions() ); + 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 ) { + cbl_enabled_exceptions_t& enabled_exceptions( cdf_enabled_exceptions() ); + 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" @@ -11090,7 +12123,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); } @@ -11098,18 +12131,24 @@ struct string_match { const char * keyword_str( int token ) { - if( token == YYEOF ) return "YYEOF"; - if( token == YYEMPTY ) return "YYEMPTY"; - + switch( token ) { + case YYEOF: return "YYEOF"; + case YYEMPTY: return "YYEMPTY"; + case 256: return "YYerror"; + case 257: return "invalid token"; // YYUNDEF + } + if( token < 256 ) { static char ascii[2]; ascii[0] = token; return ascii; } - return tokens.name_of(token); + return cdf_tokens.name_of(token); } +bool iso_cobol_word( const std::string& name, bool include_context ); + /* * Return the token for the Cobol name, unless it is a function name. The * lexer uses keyword_tok to determine if what appears to be a NAME is in fact @@ -11119,14 +12158,9 @@ keyword_str( int token ) { * REPOSITORY names. */ -// tokens.h is generated as needed from parse.h with tokens.h.gen -tokenset_t::tokenset_t() { -#include "token_names.h" -} - // Look up the lowercase form of a keyword, excluding some CDF names. int -tokenset_t::find( const cbl_name_t name, bool include_intrinsics ) { +current_tokens_t::tokenset_t::find( const cbl_name_t name, bool include_intrinsics ) { static const cbl_name_t non_names[] = { // including CDF NAMES, and "SWITCH" "CHECKING", "LIST", "LOCATION", "MAP", "SWITCH", }, * const eonames = non_names + COUNT_OF(non_names); @@ -11142,9 +12176,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); @@ -11153,27 +12187,35 @@ 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 keyword_tok( const char * text, bool include_intrinsics ) { - return tokens.find(text, include_intrinsics); + return cdf_tokens.find(text, include_intrinsics); } static inline size_t verify_figconst( enum cbl_figconst_t figconst , size_t pos ) { - cbl_field_t *f = cbl_field_of(symbol_at(pos)); + const cbl_field_t *f = cbl_field_of(symbol_at(pos)); assert((f->attr & FIGCONST_MASK) == figconst); return pos; } @@ -11198,7 +12240,7 @@ relop_of(int token) { switch(token) { case '<': return lt_op; case LE: return le_op; - case '=': return eq_op; + case EQ: return eq_op; case NE: return ne_op; case GE: return ge_op; case '>': return gt_op; @@ -11219,7 +12261,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 } @@ -11231,7 +12273,7 @@ relop_debug_str(int token) { case 0: return "zilch"; case '<': return "<"; case LE: return "LE"; - case '=': return "="; + case EQ: return "="; case NE: return "NE"; case GE: return "GE"; case '>': return ">"; @@ -11245,7 +12287,7 @@ token_of(enum relop_t op) { switch(op) { case lt_op: return '<'; case le_op: return LE; - case eq_op: return '='; + case eq_op: return EQ; case ne_op: return NE; case ge_op: return GE; case gt_op: return '>'; @@ -11360,7 +12402,7 @@ label_add( const YYLTYPE& loc, name, cbl_label_of(p)->name, cbl_label_of(p)->line); } } - struct cbl_label_t label = { type, parent, loc.last_line }; + struct cbl_label_t label = { type, parent, loc.first_line }; if( !namcpy(loc, label.name, name) ) return NULL; auto p = symbol_label_add(PROGRAM, &label); @@ -11371,11 +12413,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; } @@ -11396,7 +12433,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 ); } @@ -11436,34 +12473,15 @@ 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; } -static struct cbl_refer_t * -use_vargs( struct vargs_t *v, struct cbl_refer_t *tgt) { - assert(v); - assert(tgt); - std::copy(v->args.begin(), v->args.end(), tgt); - v->args.clear(); - delete v; - - return tgt; -} - void current_t::repository_add_all() { assert( !programs.empty() ); @@ -11489,7 +12507,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()); @@ -11531,12 +12549,15 @@ 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", + auto loc = current_location; + if( ! is_temporary(arg.field) ) { + loc = symbol_field_location(field_index(arg.field)); + } + 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; @@ -11552,7 +12573,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 ) { @@ -11588,7 +12612,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; @@ -11602,16 +12626,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 * @@ -11654,14 +12678,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 @@ -11677,8 +12696,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; } @@ -11695,8 +12713,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; } @@ -11714,8 +12731,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; } @@ -11725,48 +12741,45 @@ 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) ); + dbgmsg( "%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 ) { - std::vector <stringify_src_t> sources(inputs->lists.size()); - if( inputs->lists.back().marker == NULL ) { inputs->lists.back().marker = cbl_refer_t::empty(); } 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); - } + + std::vector <stringify_src_t> sources(inputs->lists.begin(), inputs->lists.end()); + 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, @@ -11774,6 +12787,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 ); @@ -11885,15 +12899,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 * @@ -11905,28 +12923,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] ); @@ -11985,7 +13004,6 @@ data_category_of( const cbl_refer_t& refer ) { case FldIndex: case FldSwitch: case FldDisplay: - case FldBlob: return data_category_none; } gcc_unreachable(); @@ -12018,54 +13036,54 @@ valid_target( const cbl_refer_t& refer ) { case FldIndex: case FldSwitch: case FldDisplay: - case FldBlob: return false; } gcc_unreachable(); return false; } -static _Float128 +static REAL_VALUE_TYPE numstr2i( const char input[], radix_t radix ) { - _Float128 output = 0.0; - size_t bit, integer = 0; - int erc=0, n=0; + REAL_VALUE_TYPE output; + size_t integer = 0; + fmt_size_t integerf = 0; + int erc=0; switch( radix ) { case decimal_e: { // Use decimal point for comma, just in case. - auto local = xstrdup(input), pend = local; + auto local = xstrdup(input); if( !local ) { erc = -1; break; } std::replace(local, local + strlen(local), ',', '.'); - output = strtof128(local, &pend); - n = pend - local; + real_from_string3 (&output, local, TYPE_MODE (float128_type_node)); } break; case hexadecimal_e: - erc = sscanf(input, "%zx%n", &integer, &n); - output = 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); - return integer; + dbgmsg("'%s' was accepted as %lu", input, (unsigned long)integer); + break; } switch(*p) { - case '0': bit = 0; break; - case '1': bit = 1; break; + case '0': + case '1': + integer = (integer << (p - input)); + integer |= ((*p) == '0' ? 0 : 1); break; default: - yywarn("'%s' was accepted as %d", input, integer); - return integer; + dbgmsg("'%s' was accepted as %lu", input, (unsigned long)integer); + break; } - integer = (integer << (p - input)); - integer |= bit; } - return integer; - break; + real_from_integer (&output, VOIDmode, integer, UNSIGNED); + return output; } - if( erc == -1 || n < int(strlen(input)) ) { - yywarn("'%s' was accepted as %lld", input, output); + if( erc == -1 ) { + cbl_message(ParNumstrW, "'%s' was accepted as %zu", input, integer); } return output; } @@ -12091,7 +13109,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; @@ -12105,7 +13123,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 ); @@ -12113,7 +13131,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; @@ -12137,7 +13155,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); @@ -12152,18 +13170,18 @@ struct expand_group : public std::list<cbl_refer_t> { }; -static const char * initial_default_value; - const char * wsclear() { return initial_default_value; } +static const uint32_t * initial_default_value; + const uint32_t * wsclear() { return initial_default_value; } void -wsclear( char ch ) { - static char byte = ch; - initial_default_value = &byte; +wsclear( uint32_t i ) { + static uint32_t init_val = i; + initial_default_value = &init_val; current.program_needs_initial(); } 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); @@ -12172,13 +13190,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, @@ -12207,9 +13226,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; } @@ -12226,10 +13242,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 @@ -12242,87 +13254,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 ); @@ -12338,17 +13287,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; } @@ -12358,7 +13307,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; } } @@ -12371,14 +13320,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 ) { @@ -12415,7 +13358,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; @@ -12460,10 +13403,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 ); } } @@ -12530,29 +13469,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 ); } @@ -12561,13 +13478,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 @@ -12584,14 +13501,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 ) @@ -12616,7 +13533,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& @@ -12651,10 +13568,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'); @@ -12662,7 +13580,7 @@ new_literal( const literal_t& lit, enum cbl_field_attr_t attr ) { attrs |= constant_e; attrs |= literal_attr(lit.prefix); - return new_literal(lit.len, lit.data, cbl_field_attr_t(attrs)); + return new_literal(lit.len, lit.data, cbl_field_attr_t(attrs), lit.encoding); } bool @@ -12687,7 +13605,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 ) { @@ -12734,6 +13652,82 @@ 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)); +} + +const char * +literal_t::symbol_name() const { + return isym? cbl_field_of(symbol_at(isym))->name : ""; +} + +literal_t& +literal_t::set( const cbl_field_t * field ) { + assert(field->has_attr(constant_e)); + assert(is_literal(field)); + + set_prefix( "", 0 ); + set_data( field->data.capacity, + const_cast<char*>(field->data.initial), + field_index(field) ); + return *this; +} + +literal_t& +literal_t::set_prefix( const char *input, size_t len ) { + encoding = current_encoding(display_encoding_e); + assert(len < sizeof(prefix)); + std::fill(prefix, prefix + sizeof(prefix), '\0'); + std::transform(input, input + len, prefix, toupper); + switch(prefix[0]) { + case '\0': case 'Z': + encoding = current_encoding(display_encoding_e); + break; + case 'N': + encoding = current_encoding(national_encoding_e); + if( 'X' == prefix[1] ) { + cbl_unimplemented("NX literals"); + } + break; + case 'G': + cbl_unimplemented("DBCS encoding not supported"); + break; + case 'U': + encoding = UTF8_e; + break; + case 'X': + break; + default: + gcc_unreachable(); + } + assert(valid_encoding(encoding)); + return *this; +} + + cbl_field_attr_t literal_attr( const char prefix[] ) { switch(strlen(prefix)) { @@ -12742,7 +13736,8 @@ literal_attr( const char prefix[] ) { case 1: switch(prefix[0]) { case 'B': return bool_encoded_e; - case 'N': cbl_unimplemented("National"); return none_e; + case 'N': + case 'U': return none_e; // nothing to say yet case 'X': return hex_encoded_e; case 'Z': return quoted_e; } @@ -12753,14 +13748,15 @@ literal_attr( const char prefix[] ) { case 'X': switch(prefix[0]) { case 'B': return cbl_field_attr_t(hex_encoded_e | bool_encoded_e); - case 'N': cbl_unimplemented("National"); return none_e; + case 'N': cbl_unimplemented("Hexadecimal National"); return none_e; + case 'U': cbl_unimplemented("Hexadecimal Unicode"); return none_e; } break; } } // 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; } @@ -12773,28 +13769,6 @@ cbl_field_t::has_subordinate( const cbl_field_t *that ) const { return false; } -bool -cbl_field_t::value_set( _Float128 value ) { - data = value; - char *initial = string_of(data.value_of()); - if( !initial ) return false; - - // Trim trailing zeros. - char *p = initial + strlen(initial); - for( --p; initial <= p; --p ) { - if( *p != '0' ) break; - *p = '\0'; - } - - data.digits = (p - initial) + 1; - p = strchr(initial, '.'); - data.rdigits = p? initial + data.digits - p : 0; - - data.initial = initial; - data.capacity = type_capacity(type, data.digits); - return true; -} - const char * cbl_field_t::value_str() const { if( data.etc_type == cbl_field_data_t::value_e ) @@ -12814,15 +13788,28 @@ 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_iso_e: + case dialect_gcc_e: + break; + case dialect_ibm_e: + cobol_gcobol_feature_set(feature_embiggen_e); + break; + case dialect_mf_e: + break; + case dialect_gnu_e: + if( 0 == (cbl_dialects & dialect) ) { // first time + cdf_tokens.equate(YYLTYPE(), "BINARY-DOUBLE", "BINARY-C-LONG"); + } + break; + } + cbl_dialects |= dialect; } -cbl_dialect_t cobol_dialect() { return cbl_dialect; } static bool internal_ebcdic_locked = false; @@ -12837,6 +13824,8 @@ bool cobol_gcobol_feature_set( cbl_gcobol_feature_t gcobol_feature, bool on ) { if( gcobol_feature == feature_internal_ebcdic_e ) { if( internal_ebcdic_locked ) return false; + if( ! on ) gcc_unreachable(); + current.default_encoding.set(EBCDIC_e); } if( on ) { cbl_gcobol_features |= gcobol_feature; @@ -12855,36 +13844,37 @@ literal_refmod_valid( YYLTYPE loc, const cbl_refer_t& r ) { if( ! is_literal(refmod.from->field) ) { if( ! refmod.len ) return true; if( ! is_literal(refmod.len->field) ) return true; - auto edge = refmod.len->field->data.value_of(); + auto edge = refmod.len->field->as_integer(); if( 0 < edge ) { - if( --edge < r.field->data.capacity ) return true; + if( edge-1 < r.field->data.capacity ) return true; } // len < 0 or not: 0 < from + len <= capacity error_msg(loc, "%s(%s:%zu) out of bounds, " "size is %u", r.field->name, refmod.from->name(), - size_t(refmod.len->field->data.value_of()), + size_t(edge), static_cast<unsigned int>(r.field->data.capacity) ); return false; } - if( refmod.from->field->data.value_of() > 0 ) { - auto edge = refmod.from->field->data.value_of(); + auto edge = refmod.from->field->as_integer(); + if( edge > 0 ) { if( --edge < r.field->data.capacity ) { if( ! refmod.len ) return true; if( ! is_literal(refmod.len->field) ) return true; - if( refmod.len->field->data.value_of() > 0 ) { - edge += refmod.len->field->data.value_of(); + auto len = refmod.len->field->as_integer(); + if( len > 0 ) { + edge += len; 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, - size_t(refmod.from->field->data.value_of()), - size_t(refmod.len->field->data.value_of()), + size_t(refmod.from->field->as_integer()), + size_t(len), static_cast<unsigned int>(r.field->data.capacity) ); return false; } @@ -12892,7 +13882,7 @@ literal_refmod_valid( YYLTYPE loc, const cbl_refer_t& r ) { // not: 0 < from <= capacity error_msg(loc,"%s(%zu) out of bounds, size is %u", r.field->name, - size_t(refmod.from->field->data.value_of()), + size_t(refmod.from->field->as_integer()), static_cast<unsigned int>(r.field->data.capacity) ); return false; } @@ -12902,30 +13892,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; @@ -12947,14 +13941,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; @@ -12963,7 +13957,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; @@ -12971,6 +13965,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() @@ -12988,7 +13993,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; } @@ -13097,3 +14103,4 @@ eval_subject_t::compare( const cbl_refer_t& object, parser_relop(result, subject, eq_op, object); return result; } + diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h index 8ae51c5..54d1f9a 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> @@ -41,14 +41,12 @@ #define MAXLENGTH_FORMATTED_DATE 10 #define MAXLENGTH_FORMATTED_TIME 19 +#define MAXLENGTH_CALENDAR_DATE 21 #define MAXLENGTH_FORMATTED_DATETIME 30 #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; @@ -72,42 +70,55 @@ 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(); \ + location_set(Current); \ } while (0) int yylex(void); extern int yydebug; -#include <stdarg.h> +#include <cstdarg> + +// These programs in libgcobol/compat are allowed to use ANY LENGTH even though +// they look like top-level programs. +static const std::set<std::string> compat_programs { + "CBL_ALLOC_MEM", + "CBL_CHECK_FILE_EXIST", + "CBL_DELETE_FILE", + "CBL_FREE_MEM", +}; const char * consistent_encoding_check( const YYLTYPE& loc, const char input[] ) { @@ -130,8 +141,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; @@ -141,7 +150,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,20 +190,21 @@ has_clause( int data_clauses, data_clause_t 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 @@ -207,6 +218,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) @@ -220,7 +234,13 @@ namcpy(const YYLTYPE& loc, cbl_name_t tgt, const char *src ) { } cbl_field_t * -new_alphanumeric( size_t capacity ); +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 ) { @@ -235,9 +255,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 ); @@ -261,8 +281,11 @@ static inline char * dequote( char input[] ) { static const char * name_of( cbl_field_t *field ) { assert(field); + if( field->data.initial == nullptr ) { + return field->name; + } return field->name[0] == '_' && field->data.initial? - field->data.initial : field->name; + field->data.original() : field->name; } static const char * @@ -280,7 +303,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) @@ -311,21 +334,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); } } @@ -356,13 +380,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; @@ -378,7 +403,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; @@ -427,7 +452,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; } @@ -437,17 +462,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; @@ -455,11 +481,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() { @@ -475,21 +502,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); @@ -523,7 +551,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 ); @@ -541,8 +569,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 ); @@ -605,7 +635,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(); } @@ -711,6 +741,8 @@ class eval_subject_t { } }; +static std::stack<cbl_label_t *> xml_statements; + class evaluate_t : private std::stack<eval_subject_t> { public: size_t depth() const { return size(); } @@ -736,6 +768,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; @@ -775,11 +808,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()); @@ -878,7 +910,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); } @@ -916,130 +948,17 @@ teed_up_names() { return name_queue_t::namelist_of( name_queue.peek() ); } -class tokenset_t { - std::vector<const char *>token_names; - std::map <std::string, int> tokens; - std::set<std::string> cobol_words; - - static std::string - lowercase( const cbl_name_t name ) { - cbl_name_t lname; - std::transform(name, name + strlen(name) + 1, lname, ftolower); - return lname; - } - - 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 ) { - 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); - return false; - } - auto p = tokens.find(lowercase(name)); - bool fOK = p == tokens.end(); - if( fOK ) { // name not already in use - tokens[lname] = token; - } else { - error_msg(loc, "EQUATE: %s already defined as a token", name); - } - return fOK; - } - bool undefine( const YYLTYPE& loc, const cbl_name_t name ) { - auto lname( lowercase(name) ); - auto cw = cobol_words.insert(lname); - if( ! cw.second ) { - error_msg(loc, "COBOL-WORDS UNDEFINE: %s may appear but once", name); - return false; - } - 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); - } - 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 reserve( const YYLTYPE& loc, const cbl_name_t name ) { - auto lname( lowercase(name) ); - auto cw = cobol_words.insert(lname); - if( ! cw.second ) { - error_msg(loc, "COBOL-WORDS RESERVE: %s may appear but once", name); - return false; - } - tokens[lname] = -42; - return true; - } - int redefined_as( const cbl_name_t name ) { - auto lname( lowercase(name) ); - if( cobol_words.find(lname) != cobol_words.end() ) { - auto p = tokens.find(lname); - if( p != tokens.end() ) { - return p->second; - } - } - return 0; - } - const char * name_of( int tok ) const { - tok -= (255 + 3); - gcc_assert(0 <= tok && size_t(tok) < token_names.size()); - return token_names[tok]; - } -}; - -class current_tokens_t { - tokenset_t tokens; - public: - current_tokens_t() {} - int find( const cbl_name_t name, bool include_intrinsics ) { - return tokens.find(name, include_intrinsics); - } - bool equate( const YYLTYPE& loc, cbl_name_t keyword, const cbl_name_t name ) { - int token = keyword_tok(keyword); - if( 0 == token ) { - error_msg(loc, "EQUATE %s: not a valid token", keyword); - return false; - } - return tokens.equate(loc, token, name); - } - 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; - } - return tokens.substitute(loc, keyword, token, name); - } - bool reserve( const YYLTYPE& loc, const cbl_name_t name ) { - return tokens.reserve(loc, name); - } - int redefined_as( const cbl_name_t name ) { - return tokens.redefined_as(name); - } - const char * name_of( int tok ) const { - return tokens.name_of(tok); - } -} tokens; +#define cdf_tokens cdf_current_tokens() int redefined_token( const cbl_name_t name ) { - return tokens.redefined_as(name); + return cdf_tokens.redefined_as(name); } struct file_list_t { list<cbl_file_t*> files; file_list_t() {} - file_list_t( cbl_file_t* file ) { + explicit file_list_t( cbl_file_t* file ) { files.push_back(file); } file_list_t( file_list_t& that ) : files(that.files.size()) { @@ -1053,10 +972,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 ** @@ -1083,7 +1007,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; @@ -1105,13 +1029,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) @@ -1131,7 +1062,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 ); } @@ -1157,48 +1088,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() { @@ -1223,7 +1119,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) @@ -1247,7 +1143,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; } @@ -1269,7 +1165,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) @@ -1285,7 +1181,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); } @@ -1361,8 +1257,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(); } }; @@ -1377,14 +1273,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(); } @@ -1405,7 +1301,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; } }; @@ -1422,34 +1318,48 @@ std::map<std::string, std::list<std::string>> class prog_descr_t { std::set<std::string> call_targets, subprograms; - public: + std::set<cbl_locale_t> locales; +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) - : name(""), os_name(os_name) { - if( name ) { - bool ok = namcpy(YYLTYPE(), this->name, name); - gcc_assert(ok); + struct encoding_t { + struct encoding_base_t { + size_t isym; + cbl_encoding_t encoding; + encoding_base_t() : isym(0), encoding(CP1252_e) {} + encoding_base_t(cbl_encoding_t encoding) : isym(0), encoding(encoding) {} + void set( size_t isym, cbl_encoding_t encoding ) { + this->isym = isym; + this->encoding = encoding; } - } - } locale; - cbl_call_convention_t call_convention; + void set( cbl_encoding_t encoding ) { + assert(encoding != custom_encoding_e); + this->isym = 0; + this->encoding = encoding; + } + + } alpha, national; + encoding_t() : national(EBCDIC_e) {} + } alphabet; + + bool locale_add( const cbl_locale_t& locale ) { + auto e = symbol_locale_add(program_index, &locale); + assert(e); + auto p = locales.insert(locale); + return p.second; + } + cbl_options_t options; - prog_descr_t( size_t isymbol ) + explicit prog_descr_t( size_t isymbol ) : program_index(isymbol) - , declaratives_index(0) , declaratives_eval(NULL) , paragraph(NULL) , section(NULL) , collating_sequence(NULL) - { - call_convention = current_call_convention(); - } + {} std::set<std::string> external_targets() { std::set<std::string> externals; @@ -1538,24 +1448,13 @@ static cbl_label_t * implicit_section(); class program_stack_t : protected std::stack<prog_descr_t> { struct pending_t { - cbl_call_convention_t call_convention; bool initial; - pending_t() - : call_convention(cbl_call_convention_t(0)) - , initial(false) - {} + pending_t() : initial(false) {} } pending; public: - cbl_call_convention_t - pending_call_convention( cbl_call_convention_t convention ) { - return pending.call_convention = convention; - } bool pending_initial() { return pending.initial = true; } void push( prog_descr_t descr ) { - cbl_call_convention_t current_call_convention = cbl_call_cobol_e; - if( !empty() ) current_call_convention = top().call_convention; - descr.call_convention = current_call_convention; std::stack<prog_descr_t>& me(*this); me.push(descr); } @@ -1581,9 +1480,6 @@ class program_stack_t : protected std::stack<prog_descr_t> { } void apply_pending() { - if( size() == 1 && 0 != pending.call_convention ) { - top().call_convention = pending.call_convention; - } if( pending.initial ) { auto e = symbol_at(top().program_index); auto prog(cbl_label_of(e)); @@ -1591,11 +1487,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; @@ -1603,6 +1500,7 @@ class program_stack_t : protected std::stack<prog_descr_t> { } return eval; } + // cppcheck-suppress-end useStlAlgorithm }; struct rel_part_t { @@ -1610,9 +1508,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), @@ -1646,7 +1548,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)); @@ -1705,18 +1607,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() ) { @@ -1734,6 +1629,8 @@ static class current_t { rel_part_t antecedent_cache; public: + static prog_descr_t::encoding_t::encoding_base_t default_encoding; + current_t() : first_statement(0) , in_declaratives(false) @@ -1812,6 +1709,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; @@ -1819,6 +1720,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(); } @@ -1836,7 +1744,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", @@ -1848,14 +1756,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 ) { @@ -1865,7 +1805,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 ) { @@ -1921,12 +1860,39 @@ 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; + } + + void alpha_encoding( size_t isym, cbl_encoding_t encoding ) { + prog_descr_t& program = programs.top(); + program.alphabet.alpha.set(isym, encoding); + } + void national_encoding( size_t isym, cbl_encoding_t encoding ) { + prog_descr_t& program = programs.top(); + program.alphabet.national.set(isym, encoding); + } + + cbl_encoding_t alpha_encoding() const { + if( programs.empty() ) return CP1252_e; + const prog_descr_t& program = programs.top(); + return program.alphabet.alpha.encoding; + } + cbl_encoding_t national_encoding() const { + cbl_encoding_t when_empty = EBCDIC_e; + char *alternate = getenv("NATIONAL"); + if( alternate ) + { + when_empty = __gg__encoding_iconv_type(alternate); + gcc_assert(when_empty); + } + if( programs.empty() ) return when_empty; + const prog_descr_t& program = programs.top(); + return program.alphabet.national.encoding; } bool @@ -1949,36 +1915,8 @@ static class current_t { return programs.top().options.default_round = mode; } - cbl_call_convention_t - call_convention() { - return programs.empty()? cbl_call_cobol_e : programs.top().call_convention; - } - cbl_call_convention_t - call_convention( cbl_call_convention_t convention) { - if( programs.empty() ) { - return programs.pending_call_convention(convention); - } - auto& prog( programs.top() ); - return prog.call_convention = convention; - } - - const char * - locale() { - return programs.empty()? NULL : programs.top().locale.os_name; - } - const char * - locale( const cbl_name_t name ) { - if( programs.empty() ) return NULL; - const prog_descr_t::locale_t& locale = programs.top().locale; - return 0 == strcmp(name, locale.name)? locale.name : NULL; - } - const prog_descr_t::locale_t& - locale( const cbl_name_t name, const char os_name[] ) { - if( programs.empty() ) { - static prog_descr_t::locale_t empty; - return empty; - } - return programs.top().locale = prog_descr_t::locale_t(name, os_name); + bool locale_add( const cbl_locale_t& locale ) { + return programs.top().locale_add(locale); } bool new_program ( const YYLTYPE& loc, cbl_label_type_t type, @@ -1997,7 +1935,16 @@ 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))); + prog_descr_t program(symbol_index(symbol_elem_of(L))); +#if 1 //EBCDIC // enable when ready + auto alpha_encoding = + programs.empty()? default_encoding : programs.top().alphabet.alpha; + if( alpha_encoding.encoding == EBCDIC_e ) { + dbgmsg("%s:%d: We're in EBCDIC", __func__, __LINE__); + } + program.alphabet.alpha = alpha_encoding; +#endif + programs.push( program ); programs.apply_pending(); bool fOK = symbol_at(programs.top().program_index) + 1 == symbols_end(); @@ -2021,10 +1968,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)); @@ -2038,12 +1981,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; @@ -2059,13 +2006,14 @@ static class current_t { * ISO, in new_program. */ std::set<std::string> end_program() { + cbl_enabled_exceptions_t& enabled_exceptions( cdf_enabled_exceptions() ); if( enabled_exceptions.size() ) { - declaratives_evaluate(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(); /* @@ -2076,9 +2024,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)); @@ -2086,11 +2044,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(); } @@ -2104,8 +2067,9 @@ static class current_t { exception_clients.clear(); if( ref ) { - yywarn("could not resolve paragraph (or section) '%s' at line %d", - ref->paragraph(), ref->line_number()); + cbl_message(ParUnresolvedProcE, + "could not resolve paragraph (or section) '%s' at line %d", + ref->paragraph(), ref->line_number()); // add string to indicate ambiguity error externals.insert(":ambiguous:"); } @@ -2120,7 +2084,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; @@ -2130,24 +2094,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; } @@ -2155,14 +2122,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. @@ -2172,18 +2157,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(); @@ -2211,7 +2186,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 @@ -2222,16 +2197,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 ) { @@ -2242,11 +2210,10 @@ static class current_t { } void antecedent_dump() const { - if( ! yydebug ) return; if( ! antecedent_cache.operand ) { - yywarn( "Antecedent: none" ); + dbgmsg( "Antecedent: none" ); } else { - yywarn( "Antecedent: %c %s %s %c", + dbgmsg( "Antecedent: %c %s %s %c", antecedent_cache.invert? '!':' ', name_of(antecedent_cache.operand->field), relop_str(antecedent_cache.relop), @@ -2275,28 +2242,56 @@ static class current_t { cbl_label_t * compute_label() { return error_labels.compute_error; } } current; +prog_descr_t::encoding_t::encoding_base_t current_t::default_encoding; + +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() { +cbl_options_t +current_options() { return current.options_paragraph; } -size_t current_program_index() { +cbl_encoding_t +current_encoding( char a_or_n ) { + cbl_encoding_t retval; + switch(a_or_n) { + case 'A': + retval = current.alpha_encoding(); + break; + case 'N': + retval = current.national_encoding(); + break; + default: + gcc_unreachable(); + break; + } + return retval; +} + +size_t +current_program_index() { return current.program()? current.program_index() : 0; } -cbl_label_t * current_section() { +cbl_label_t * +current_section() { return current.section(); } -cbl_label_t * current_paragraph() { +cbl_label_t * +current_paragraph() { return current.paragraph(); } @@ -2325,15 +2320,6 @@ current_rounded_mode( cbl_round_t rounded) { #endif static cbl_round_t current_rounded_mode( int token ); -cbl_call_convention_t -current_call_convention() { - return current.call_convention(); -} -cbl_call_convention_t -current_call_convention( cbl_call_convention_t convention) { - return current.call_convention(convention); -} - size_t program_level() { return current.program_level(); } static size_t constant_index( int token ); @@ -2353,10 +2339,19 @@ 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, cbl_field_attr_t attr = signable_e ) { + return new_temporary(FldNumericBin5, name, attr == signable_e); +} static inline cbl_field_t * -new_tempnumeric_float(void) { return new_temporary(FldFloat); } +new_tempnumeric(const cbl_field_attr_t attr ) { + return new_temporary(FldNumericBin5, nullptr, attr == signable_e); +} + +static inline cbl_field_t * +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 ); @@ -2374,11 +2369,32 @@ 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; - const char *initial = field->data.initial; - - return 1 == sscanf(initial, "%d%n", &v, &n) && n == (int)strlen(initial); + if( field->type == FldLiteralN ) { + size_t nchar; + const char *initial = __gg__iconverter(field->codeset.encoding, + DEFAULT_SOURCE_ENCODING, + field->data.initial, + strlen(field->data.initial), + &nchar); + assert(strlen(initial) == nchar); + 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; } @@ -2408,7 +2424,6 @@ needs_picture( cbl_field_type_t type ) { case FldNumericBin5: return false; - case FldBlob: case FldClass: case FldConditional: case FldForward: @@ -2437,7 +2452,6 @@ is_callable( const cbl_field_t *field ) { case FldForward: case FldSwitch: case FldDisplay: - case FldBlob: case FldNumericDisplay: case FldNumericBinary: case FldFloat: @@ -2452,7 +2466,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; } @@ -2499,16 +2514,16 @@ 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); return false; } - const char *fund = intrinsic_cname(token); - if( !fund ) return false; - parser_intrinsic_call_2( tgt, fund, args[0], args[1] ); + const char *func = intrinsic_cname(token); + if( !func ) return false; + parser_intrinsic_call_2( tgt, func, args[0], args[1] ); return true; } @@ -2577,18 +2592,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 * @@ -2790,17 +2801,6 @@ group_attr( const cbl_field_t * field ) { return p->attr; } -static struct symbol_elem_t * -field_of( const char F[], int L, const char name[] ) { - struct symbol_elem_t *e = symbol_field(PROGRAM, 0, name); - if( !e ) { - cbl_internal_error("%s:%d: no symbol '%s' found", F, L, name); - } - assert( procedure_div_e != current_division ); - return e; -} -#define field_of( F ) field_of(__func__, __LINE__, (F)) - static struct cbl_field_t * field_add( const YYLTYPE& loc, cbl_field_t *field ) { switch(current_data_section) { @@ -2847,7 +2847,7 @@ field_attr_str( const cbl_field_t *field ) { intermediate_e, embiggened_e, all_alpha_e, all_x_e, all_ax_e, prog_ptr_e, scaled_e, refmod_e, based_e, any_length_e, global_e, external_e, blank_zero_e, linkage_e, local_e, leading_e, - separate_e, envar_e, dnu_1_e, bool_encoded_e, hex_encoded_e, + separate_e, envar_e, encoded_e, bool_encoded_e, hex_encoded_e, depends_on_e, initialized_e, has_value_e, ieeedec_e, big_endian_e, same_as_e, record_key_e, typedef_e, strongdef_e, }; @@ -2955,29 +2955,39 @@ blank_pad_initial( const char initial[], size_t capacity, size_t new_size ) { return p; } -static bool +/* + * When cbl_field_t::internalize is called, its data.initial value has been + * set, but nothing has been done to it. It is encoded according to the source + * code. internalize() converts data.initial to the field's encoding. + * + * If syntax used was was PIC VALUE, in that order, then PIC set the field's + * encoding, and the VALUE clause can verify that its encoding matches. If the + * order was VALUE PIC, the value leaves the encoding uninitialized unless the + * value string bore an encoding prefix. When PIC is processed, codeset_t::set + * allows it to set the encoding only if it's either uninitialized, or the PIC + * encoding matches the existing one set by VALUE. In no event does one + * override the other; they must agree. + * + * internalize() fails if data.initial cannot be converted to the field's + * encoding. + */ +static void value_encoding_check( const YYLTYPE& loc, cbl_field_t *field ) { if( ! field->internalize() ) { error_msg(loc, "inconsistent string literal encoding for '%s'", field->data.initial); - return false; } - return true; } - #pragma GCC diagnostic push #pragma GCC diagnostic ignored "-Wmissing-field-initializers" static struct cbl_field_t * field_alloc( const YYLTYPE& loc, cbl_field_type_t type, size_t parent, const char name[] ) { - cbl_field_t *f, field = {}; - field.type = type; - field.usage = FldInvalid; + static const uint32_t level = 0; + cbl_field_t *f, field = { type, 0, cbl_field_data_t(), level, name, yylineno }; field.parent = parent; - field.line = yylineno; - if( !namcpy(loc, field.name, name) ) return NULL; f = field_add(loc, &field); assert(f); return f; @@ -2993,7 +3003,7 @@ static cbl_file_t * file_add( YYLTYPE loc, cbl_file_t *file ) { gcc_assert(file); enum { level = 1 }; - struct cbl_field_t area = { 0, FldAlphanumeric, FldInvalid, 0, 0,0, level, {}, yylineno }, + struct cbl_field_t area{ FldAlphanumeric, level, yylineno }, *field = field_add(loc, &area); file->default_record = field_index(field); @@ -3005,13 +3015,14 @@ 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); } field->file = field->parent = symbol_index(e); + field->codeset.set(); return file; } @@ -3020,12 +3031,16 @@ file_add( YYLTYPE loc, cbl_file_t *file ) { static cbl_alphabet_t * -alphabet_add( const YYLTYPE& loc, cbl_encoding_t encoding ) { - cbl_alphabet_t alphabet(loc, encoding); +alphabet_add( const cbl_alphabet_t& alphabet ) { symbol_elem_t *e = symbol_alphabet_add(PROGRAM, &alphabet); assert(e); return cbl_alphabet_of(e); } +static cbl_alphabet_t * +alphabet_add( const YYLTYPE& loc, cbl_encoding_t encoding ) { + cbl_alphabet_t alphabet(loc, encoding); + return alphabet_add(alphabet); +} // The current field always exists in the symbol table, even if it's incomplete. static cbl_field_t * @@ -3036,6 +3051,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); @@ -3047,15 +3073,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); } @@ -3078,6 +3119,10 @@ 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 ) { + dialect_ok(src.loc, MfMovePointer, "MOVE POINTER"); + } if( ! is_index ) { char ach[16]; char stype[32]; @@ -3103,7 +3148,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); @@ -3137,13 +3181,23 @@ ast_set_pointers( const list<cbl_num_result_t>& tgts, cbl_refer_t src ) { parser_set_pointers(nptr, ptrs.data(), src); } +static void +ast_save_locale( cbl_refer_t refer, int /* token */ ) { + assert( ! refer.addr_of && ! refer.is_reference() ); + if( ! refer.is_pointer() ) { + error_msg(refer.loc, "%s must be USAGE POINTER", refer.name()); + return; + } + cbl_unimplemented("SET identifier-11 TO LOCALE"); +} + 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 ); @@ -3152,7 +3206,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); } @@ -3160,12 +3215,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; @@ -3220,7 +3277,11 @@ data_division_ready() { const char *name = current.collating_sequence(); if( ! symbols_alphabet_set(PROGRAM, name) ) { - error_msg(yylloc, "no alphabet '%s' defined", name); + if( name ) { + error_msg(yylloc, "no alphabet '%s' defined", name); + } else { + error_msg(yylloc, "no alphabet defined"); + } return false; } } @@ -3229,13 +3290,15 @@ data_division_ready() { static size_t nsymbol = 0; if( (nsymbol = symbols_update(nsymbol, nparse_error == 0)) > 0 ) { if( ! literally_one ) { - literally_one = new_literal("1"); - literally_zero = new_literal("0"); + // Use strdup so cbl_field_t::internalize can free them if need be. + literally_one = new_literal(xstrdup("1")); + literally_zero = new_literal(xstrdup("0")); } } 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; } @@ -3244,7 +3307,7 @@ data_division_ready() { static bool -anybody_redefines(cbl_field_t *tree) +anybody_redefines( const cbl_field_t *tree ) { bool retval = false; while(tree) @@ -3254,7 +3317,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; } @@ -3301,6 +3365,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); @@ -3467,14 +3538,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, @@ -3522,7 +3593,7 @@ goodnight_gracie() { if( !externals.empty() ) { for( const auto& name : externals ) { - yywarn("%s calls external symbol '%s'", + dbgmsg("%s calls external symbol '%s'", prog->name, name.c_str()); } return false; @@ -3533,20 +3604,23 @@ goodnight_gracie() { return true; } -const char * keyword_str( int token ); - +// false after USE statement, to enter Declarative with EC intact. +static bool statement_cleanup = true; static YYLTYPE current_location; +static void statement_epilog( int token ); + +const char * keyword_str( int token ); + const YYLTYPE& cobol_location() { return current_location; } -static inline YYLTYPE +static inline void location_set( const YYLTYPE& loc ) { - return current_location = loc; + current_location = loc; + gcc_location_set(loc); } -static 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 18d0d82..75b2f3c 100644 --- a/gcc/cobol/scan.l +++ b/gcc/cobol/scan.l @@ -27,9 +27,15 @@ * (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" +#include "coretypes.h" +#include "tree.h" +#undef yy_flex_debug #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" @@ -73,14 +79,19 @@ nonseq (([''][[:alnum:]]+][''])|([""][[:alnum:]]+[""])) INTEGER 0*[1-9][[:digit:]]* INTEGERZ [[:digit:]]+ +NONWORD [^[:alnum:]$_-]+ + SPC [[:space:]]+ OSPC [[:space:]]* +BLANK [[:blank:]]+ +OBLANK [[:blank:]]* EOL \r?\n BLANK_EOL [[:blank:]]*{EOL} BLANK_OEOL [[:blank:]]*{EOL}? +PICTURE [^[:space:]]+ -DOTSEP [.][[:space:]] +DOTSEP [.]+[[:space:]] DOTEOL [[:blank:]]*[.]{BLANK_EOL} SKIP [[:blank:]]*SKIP[123][[:blank:]]*[.]?{BLANK_EOL} @@ -92,9 +103,10 @@ NP P+|(P{COUNT}) UNSIGNED [[:space:]]+UNSIGNED SIGNED [[:space:]]+SIGNED -DBLLONG (LONG-LONG|DOUBLE) -ALNUM [AX9]+ +PREFIX G|N|U|Z + +ALNUM [AX9]+|N+|U+ AX [AX]{COUNT}? B0 [B0/]{COUNT}? @@ -113,7 +125,7 @@ NUMEDCHAR [BPVZ90/,]+{COUNT}? NUMEDCHARS {NUMEDCHAR}([.]?{NUMEDCHAR})* NUMED ([+-]{NUMEDCHARS}+)|({NUMEDCHARS}+[+-]) CURRENCY [A-Zfhijklmoqtuwy\x80-\xFF]{-}[ABCDEGNPRSVXZ] -NUMEDCUR (([.]?[-$0B/Z*+,P9()V+–]|{CURRENCY}+|{COUNT})+([.][$0B/Z*+P9()V+\–])*)+ +NUMEDCUR (([.]?[$0B/Z*+,P9()V+-]|{CURRENCY}+|{COUNT})+([.][$0B/Z*+P9()V+-])*)+ NUMEDITED {NUMED}|{NUMEDCUR} EDITED {ALPHED}|{NUMED}|{NUMEDCUR} @@ -153,7 +165,7 @@ COMMA [,;][[:blank:]]* ISNT (IS{SPC})?NOT -COMMENTARY DATE-COMPILED|DATE-WRITTEN|INSTALLATION|SECURITY +COMMENTARY AUTHOR|DATE-COMPILED|DATE-WRITTEN|INSTALLATION|SECURITY SORT_MERGE SORT(-MERGE)? @@ -167,15 +179,15 @@ SIZE_ERROR (ON[[[:space:]]+)?SIZE[[:space:]]+ERROR VARTYPE NUMERIC|ALPHABETIC|ALPHABETIC_LOWER|ALPHABETIC_UPPER|DBCS|KANJI NAMTYP {NAME}|{VARTYPE} -NL [[:blank:]]*\r?\n[[:blank:]]* +NL [[:blank:]]*{EOL}[[:blank:]]* PUSH_FILE \f?[#]FILE{SPC}PUSH{SPC}[^\f]+\f POP_FILE \f?[#]FILE{SPC}POP\f -LINE_DIRECTIVE [#]line{SPC}[[:alnum:]]+{SPC}[""''].+\n +LINE_DIRECTIVE ^[#]line{SPC}[[:alnum:]]+{SPC}[""''].+\n %x procedure_div ident_state addr_of function classify %x program_id_state comment_entries -%x author_state date_state field_level field_state dot_state +%x date_state field_level field_state dot_state %x numeric_state name_state %x quoted1 quoted2 quoteq %x picture picture_count integer_count @@ -231,30 +243,23 @@ WORKING-STORAGE{SPC}SECTION { yy_push_state(field_state); return WORKING_STORAGE_SECT; } LOCAL-STORAGE{SPC}SECTION { - yy_push_state(field_state); - return LOCAL_STORAGE_SECT; } -WORKING-STORAGE { - return WORKING_STORAGE; } -LOCAL-STORAGE { - return LOCAL_STORAGE; } -SCREEN { - return SCREEN; } + yy_push_state(field_state); + return LOCAL_STORAGE_SECT; } +WORKING-STORAGE { return WORKING_STORAGE; } +LOCAL-STORAGE { return LOCAL_STORAGE; } +SCREEN { return SCREEN; } LINKAGE{SPC}SECTION { yy_push_state(field_state); return LINKAGE_SECT; } -FUNCTION-ID { yy_push_state(ident_state); - yy_push_state(program_id_state); - yy_push_state(name_state); return FUNCTION; } - -PROGRAM-ID { yy_push_state(ident_state); - yy_push_state(program_id_state); - yy_push_state(name_state); return PROGRAM_ID; } +FUNCTION-ID{OSPC}{DOTSEP}? { yy_push_state(ident_state); + yy_push_state(program_id_state); + yy_push_state(name_state); return FUNCTION; } -PROGRAM-ID/{DOTEOL} { yy_push_state(ident_state); - yy_push_state(name_state); - yy_push_state(dot_state); return PROGRAM_ID; } +PROGRAM-ID{OSPC}{DOTSEP}? { yy_push_state(ident_state); + yy_push_state(program_id_state); + yy_push_state(name_state); return PROGRAM_ID; } PROCEDURE{SPC}DIVISION { yy_push_state(procedure_div); return PROCEDURE_DIV; } @@ -265,29 +270,18 @@ PROCEDURE{SPC}DIVISION { yy_push_state(procedure_div); } <ident_state>{ + {BLANK_OEOL} + ID(ENTIFICATION)?{SPC}DIVISION { myless(0); yy_pop_state(); } + (ENVIRONMENT|DATA|PROCEDURE){SPC}DIVISION { + myless(0); yy_pop_state(); } + OPTIONS { myless(0); yy_pop_state(); } + AS{SPC}[""] { yy_push_state(quoted2); return AS; } AS{SPC}[''] { yy_push_state(quoted1); return AS; } IS { pop_return IS; } - OPTIONS { yy_pop_state(); myless(0); } - [[:blank:]]*(ENVIRONMENT|DATA|PROCEDURE)[[:blank:]]+DIVISION/.+\n { - yy_pop_state(); myless(0); } - [[:blank:]]*AUTHOR[[:blank:].]+{EOL}? { - // Might not have an EOL, but stop on one. - yy_push_state(author_state); } - - {DOTEOL} - {COMMENTARY} { BEGIN(comment_entries); } } -<author_state>{ - [[:blank:]]+ - ^{BLANK_EOL} - [^\r\n]+ { yy_pop_state(); - yylval.string = xstrdup(yytext); - } -} - <INITIAL>{ COBOL { return COBOL; } @@ -299,6 +293,15 @@ PROCEDURE{SPC}DIVISION { yy_push_state(procedure_div); yy_push_state(field_state); yy_set_bol(1); myless(0); } + + END{SPC}PROGRAM { yy_push_state(name_state); + return program_level() > 1? + END_SUBPROGRAM : END_PROGRAM; } + + END{SPC}FUNCTION { yy_push_state(name_state); + return program_level() > 1? + END_SUBPROGRAM /*invalid*/ : + END_FUNCTION; } } <INITIAL,procedure_div,cdf_state>{ @@ -321,6 +324,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; } @@ -371,7 +383,7 @@ ROUNDING { return ROUNDING; } SECONDS { return SECONDS; } SECURE { return SECURE; } SHORT { return SHORT; } -SIGNED { return SIGNED; } +SIGNED { return SIGNED_kw; } STANDARD-BINARY { return STANDARD_BINARY; } STANDARD-DECIMAL { return STANDARD_DECIMAL; } STATEMENT { return STATEMENT; } @@ -391,7 +403,7 @@ TOWARD-LESSER { return TOWARD_LESSER; } TRUNCATION { return TRUNCATION; } UCS-4 { return UCS_4; } UNDERLINE { return UNDERLINE; } -UNSIGNED { return UNSIGNED; } +UNSIGNED { return UNSIGNED_kw; } UTF-16 { return UTF_16; } UTF-8 { return UTF_8; } @@ -427,6 +439,11 @@ STDOUT { return STDOUT; } STDERR { return STDERR; } SYSERR { return STDERR; } +ARGUMENT-NUMBER { return ARGUMENT_NUMBER; } +ARGUMENT-VALUE { return ARGUMENT_VALUE; } +ENVIRONMENT-NAME { return ENVIRONMENT_NAME; } +ENVIRONMENT-VALUE { return ENVIRONMENT_VALUE; } + CANCEL { return CANCEL; } COMMIT { return COMMIT; } COMMON { return COMMON; } @@ -437,16 +454,26 @@ COPY { myless(0); } -EXTEND { return EXTEND;} -INITIALIZE { return INITIALIZE; } -INSPECT { return INSPECT; } -INVOKE { return INVOKE; } -INTRINSIC { return INTRINSIC; } -MERGE { return MERGE; } -UNSTRING { return UNSTRING; } -XML { return XML; } -XMLGENERATE { return XMLGENERATE; } -XMLPARSE { return XMLPARSE; } +ATTRIBUTES { return ATTRIBUTES; } +ELEMENT { return ELEMENT; } +ENCODING { return ENCODING; } +EXTEND { return EXTEND;} +INITIALIZE { return INITIALIZE; } +INSPECT { return INSPECT; } +INTRINSIC { return INTRINSIC; } +INVOKE { return INVOKE; } +MERGE { return MERGE; } +NAMESPACE { return NAMESPACE; } +NAMESPACE-PREFIX { return NAMESPACE_PREFIX; } +NONNUMERIC { return NONNUMERIC; } +PROCESSING { return PROCESSING; } +UNSTRING { return UNSTRING; } +VALIDATING { return VALIDATING; } + +XML{SPC}GENERATE { return XMLGENERATE; } +XML{SPC}PARSE { return XMLPARSE; } +XML-DECLARATION { return XML_DECLARATION; } +END-XML { return END_XML; } ZEROE?S? { return ZERO; } @@ -490,7 +517,6 @@ THAN { return THAN; } TEST { return TEST; } TERMINATE { return TERMINATE; } TALLYING { return TALLYING; } -TALLY { return TALLY; } SYSPUNCH { return SYSPUNCH; } SYSOUT { return SYSOUT; } SYSIN { return SYSIN; } @@ -524,7 +550,7 @@ SECTION{SPC}[+-]?{INTEGERZ}/{OSPC}{DOTSEP} { auto eotext = yytext + yyleng; auto p = std::find_if(yytext, eotext, fisspace); p = std::find_if(p, eotext, nonspace); - yylval.string = p; + yylval.string = xstrdup(p); return SECTION; } @@ -546,7 +572,7 @@ REVERSED { return REVERSED; } RETURN { return RETURN; } RESTRICTED { return RESTRICTED; } -RESUME { +RESUME { // RESUME is ISO syntax, not IBM. if( ! dialect_ibm() ) return RESUME; yylval.string = xstrdup(yytext); return typed_name(yytext); @@ -736,7 +762,9 @@ EVERY { return EVERY; } ERROR { return ERROR; } EVALUATE { return EVALUATE; } -EQUALS? { return '='; } +EQUALS? { ydflval.string = yylval.string = xstrdup(yytext); + return '='; } + ENVIRONMENT[[:blank:]]+DIVISION { return ENVIRONMENT_DIV; } ENTRY { return ENTRY; } @@ -787,7 +815,11 @@ DEPENDING { return DEPENDING; } DELIMITER { return DELIMITER; } DELETE { return DELETE; } -DEFAULT { return DEFAULT; } + +DEFAULT { yylval.number = 'D'; return DEFAULT; } +SYSTEM-DEFAULT { yylval.number = 'S'; return DEFAULT; } +USER-DEFAULT { yylval.number = 'U'; return DEFAULT; } + DECLARATIVES { return DECLARATIVES; } DECIMAL-POINT { return DECIMAL_POINT; } DEBUGGING { return DEBUGGING; } @@ -834,7 +866,7 @@ CALL { return CALL; } BY { return BY; } BOTTOM { return BOTTOM; } BEFORE { return BEFORE; } -BLOCK { return BLOCK; } +BLOCK { return BLOCK_kw; } BACKWARD { return BACKWARD; } AT { return AT; } @@ -851,8 +883,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; } @@ -869,11 +902,7 @@ ACCESS { return ACCESS; } ACCEPT { return ACCEPT; } DELETE { return DELETE; } -EJECT{DOTEOL}? { - if( ! dialect_ibm() ) { - dialect_error(yylloc, "EJECT is not ISO syntax,", "ibm"); - } - } +EJECT{DOTEOL}? { dialect_ok(yylloc, IbmEjectE, "EJECT"); } INSERTT { return INSERTT; } LABEL { return LABEL; } PROCESS { return PROCESS; } @@ -950,7 +979,9 @@ USE({SPC}FOR)? { return USE; } return NUMSTR; } - PIC(TURE)?({SPC}IS)?[[:space:]]{BLANK_OEOL} { + PIC(TURE)?({SPC}IS)?{SPC}{PICTURE} { + auto pos = validate_picture(); + myless(pos); yy_push_state(picture); return PIC; } ANY { return ANY; } @@ -963,31 +994,28 @@ USE({SPC}FOR)? { return USE; } COMP(UTATIONAL)?-X { return ucomputable(FldNumericBin5, 0xFF); } COMP(UTATIONAL)?-6 { return ucomputable(FldPacked, 0); } COMP(UTATIONAL)?-5 { return ucomputable(FldNumericBin5, 0); } - COMP(UTATIONAL)?-4 { return scomputable(FldNumericBinary, 0); } + COMP(UTATIONAL)?-4 { return ucomputable(FldNumericBinary, 0); } COMP(UTATIONAL)?-3 { return PACKED_DECIMAL; } COMP(UTATIONAL)?-2 { return ucomputable(FldFloat, 8); } COMP(UTATIONAL)?-1 { return ucomputable(FldFloat, 4); } 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 { return ucomputable(FldNumericBinary, 0); } + + 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 { dialect_ok(yylloc, MfBinaryLongLong, "BINARY-LONG-LONG"); + 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 @@ -997,6 +1025,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"); @@ -1009,9 +1040,8 @@ USE({SPC}FOR)? { return USE; } PROGRAM-POINTER { yylval.field_attr = prog_ptr_e; return POINTER; } POINTER { yylval.field_attr = none_e; return POINTER; } - PROCEDURE-POINTER { if( dialect_gcc() ) { - error_msg(yylloc, "%s requires -dialect ibm or mf", yytext); - } + PROCEDURE-POINTER { + dialect_ok(yylloc, IbmProcedurePointer, yytext); yylval.field_attr = prog_ptr_e; return POINTER; // return it anyway } @@ -1039,7 +1069,7 @@ USE({SPC}FOR)? { return USE; } AS { return AS; } ASCENDING { return ASCENDING; } BLANK { return BLANK; } - BLOCK { return BLOCK; } + BLOCK { return BLOCK_kw; } BY { return BY; } BYTE-LENGTH { return BYTE_LENGTH; } CHARACTER { return CHARACTER; } @@ -1051,13 +1081,11 @@ USE({SPC}FOR)? { return USE; } DEPENDING { return DEPENDING; } DESCENDING { return DESCENDING; } DISPLAY { return DISPLAY; } - EJECT{DOTEOL}? { - if( ! dialect_ibm() ) { - dialect_error(yylloc, "EJECT is not ISO syntax,", "ibm"); - } - auto len = yyleng - 1; - if( yytext[len] == '\f' ) myless(--len); - } + EJECT{DOTEOL}? { + dialect_ok(yylloc, IbmEjectE, "EJECT"); + auto len = yyleng - 1; + if( yytext[len] == '\f' ) myless(--len); + } EXTERNAL { return EXTERNAL; } FALSE { return FALSE_kw; } FROM { return FROM; } @@ -1111,22 +1139,26 @@ 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; } - Z?[''] { yylval.literal.set_prefix(yytext, yyleng-1); + {PREFIX}?[''] { yylval.literal.set_prefix(yytext, yyleng-1); yy_push_state(quoted1); } - Z?[""] { yylval.literal.set_prefix(yytext, yyleng-1); + {PREFIX}?[""] { yylval.literal.set_prefix(yytext, yyleng-1); yy_push_state(quoted2); } N?X/{hexseq} { yylval.literal.set_prefix(yytext, yyleng); yy_push_state(hex_state); } N?X{nonseq} { dbgmsg("invalid hexadecimal value: %s", yytext); return NO_CONDITION; } - [[:blank:]]*\r?\n {} + [[:blank:]]*{EOL} {} WORKING-STORAGE{SPC}SECTION { return WORKING_STORAGE_SECT; } LOCAL-STORAGE{SPC}SECTION { return LOCAL_STORAGE_SECT; } @@ -1196,7 +1228,12 @@ USE({SPC}FOR)? { return USE; } {NP}V?/[,.]? { yylval.number = ndigit(yyleng); return picset(PIC_P); } {N9}*V/{N9}* { yylval.number = ndigit(yyleng - 1); return picset(NINEV); } {N9}/{N9}*[,.]? { yylval.number = ndigit(yyleng); return picset(NINES); } - P+/[,.]?\r?\n { yylval.number = yyleng; return picset(PIC_P); } + P+/[,.]?{EOL} { yylval.number = yyleng; return picset(PIC_P); } + + 1{1,31}/({COUNT}|[(]{NAME}[)]) { + yy_push_state(picture_count); + 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); @@ -1260,12 +1297,12 @@ USE({SPC}FOR)? { return USE; } } /* CDF REPLACING needs quotes to distinquish strings from identifiers. */ - Z?['']{STRING1}[''] { auto *s = xstrdup(yytext); + {PREFIX}?['']{STRING1}[''] { auto *s = xstrdup(yytext); std::replace(s, s + strlen(s), '\'', '"'); ydflval.string = s; update_location_col(s); return LITERAL; } - Z?[""]{STRING}[""] { ydflval.string = xstrdup(yytext); + {PREFIX}?[""]{STRING}[""] { ydflval.string = xstrdup(yytext); update_location_col(yytext); return LITERAL; } [=]{4} { static char nullstring[] = ""; @@ -1290,7 +1327,7 @@ USE({SPC}FOR)? { return USE; } [""]{SPC}[&]{SPC}[""''] { if( yytext[yyleng - 1] == '\'' ) BEGIN(quoted1); } - [""]-{OSPC}(\r?\n{OSPC})+[""] /* continue ... */ + [""]-{OSPC}({EOL}{OSPC})+[""] /* continue ... */ [""] { char *s = xstrdup(tmpstring? tmpstring : "\0"); yylval.literal.set_data(strlen(s), s); @@ -1307,7 +1344,7 @@ USE({SPC}FOR)? { return USE; } ['']{SPC}[&]{SPC}[""''] { if( yytext[yyleng - 1] == '"' ) BEGIN(quoted2); } - ['']-{OSPC}(\r?\n{OSPC})+[''] /* continue ... */ + ['']-{OSPC}({EOL}{OSPC})+[''] /* continue ... */ [''] { char *s = xstrdup(tmpstring? tmpstring : "\0"); yylval.literal.set_data(strlen(s), s); @@ -1355,46 +1392,36 @@ USE({SPC}FOR)? { return USE; } } <program_id_state>{ - ^[[:blank:]]+ - ^{BLANK_EOL} + {BLANK_OEOL} (IS)?[[:space:]] + AS/{SPC} { myless(0); yy_pop_state(); } /* => ident_state */ - COMMON/[.]|{SPC}[[:alnum:].] { return COMMON; } - INITIAL/[.]|{SPC}[[:alnum:].] { return INITIAL_kw; } - RECURSIVE { return RECURSIVE; } - PROGRAM/[.]|{SPC}[[:alnum:].] { return PROGRAM_kw; } - - INITIAL { pop_return INITIAL_kw; } - COMMON { pop_return COMMON; } - PROGRAM { pop_return PROGRAM; } + INITIAL { return INITIAL_kw; } + COMMON { return COMMON; } + RECURSIVE { return RECURSIVE; } + PROGRAM { return PROGRAM_kw; } - AS/{SPC} { myless(0); yy_pop_state(); } /* => ident_state */ - [[:blank:]]*{DOTSEP}[[:blank:].]+{EOL} { pop_return '.'; } - {DOTEOL} { pop_return '.'; } + {DOTSEP} { pop_return '.'; } } -<name_state>{ - ^[[:blank:]]+ - ^{BLANK_EOL} - {NAME}/{OSPC}[.] { yy_pop_state(); - yylval.string = xstrdup(yytext); return NAME; } - {NAME} { yy_pop_state(); - yylval.string = xstrdup(yytext); return NAME; } - - Z?[''] { yylval.literal.set_prefix(yytext, yyleng-1); - yy_push_state(quoted1); } - Z?[""] { yylval.literal.set_prefix(yytext, yyleng-1); - yy_push_state(quoted2); } +<name_state>{ /* Either pop from here, or let the quoted state pop */ + {BLANK_OEOL} - [.]/[[:blank:]]+. { return *yytext; } + {NAME} { yy_pop_state(); + yylval.string = xstrdup(yytext); + return NAME; + } + {PREFIX}?[''] { yylval.literal.set_prefix(yytext, yyleng-1); + BEGIN(quoted1); } + {PREFIX}?[""] { yylval.literal.set_prefix(yytext, yyleng-1); + BEGIN(quoted2); } - [[:blank:]]*{DOTSEP}[[:blank:].]+{EOL} { - yy_pop_state(); myless(0); } - {DOTEOL} { yy_pop_state(); myless(0); } + . { myless(0); yy_pop_state(); + /* Should not happen for valid inputs. */ } } <dot_state>{ [[:blank:]]*[.][[:blank:].]+{EOL} { pop_return '.'; } - [[:blank:]]*[.] { pop_return '.'; } + [[:blank:]]*[.]+ { pop_return '.'; } } <date_state>{ @@ -1426,11 +1453,11 @@ USE({SPC}FOR)? { return USE; } BX/{hexseq} { yylval.numstr.radix = hexadecimal_e; yy_push_state(numstr_state); } - Z?[''] { yylval.literal.set_prefix(yytext, yyleng-1); + {PREFIX}?[''] { yylval.literal.set_prefix(yytext, yyleng-1); yy_push_state(quoted1); } - Z?[""] { yylval.literal.set_prefix(yytext, yyleng-1); + {PREFIX}?[""] { yylval.literal.set_prefix(yytext, yyleng-1); yy_push_state(quoted2); } - Z?[""]/{STRING}[""] { yylval.literal.set_prefix(yytext, yyleng-1); + {PREFIX}?[""]/{STRING}[""] { yylval.literal.set_prefix(yytext, yyleng-1); yy_push_state(quoted2); } {INTEGERZ}/[[:punct:]][[:space:]]{BLANK_OEOL} { return numstr_of(yytext); } @@ -1472,22 +1499,27 @@ USE({SPC}FOR)? { return USE; } <cdf_state,procedure_div>{ (IS{SPC})?"<" { return '<'; } (IS{SPC})?"<=" { return LE; } - (IS{SPC})?"=" { return '='; } + (IS{SPC})?"=" { static char eq[] = "="; + ydflval.string = yylval.string = eq; + return EQ; } (IS{SPC})?"<>" { return NE; } (IS{SPC})?">=" { return GE; } (IS{SPC})?">" { return '>'; } - {LESS_THAN} { return '<'; } + {LESS_THAN} { return '<'; } {LESS_THAN}{SPC}{OR_EQUAL}/[[:space:]] { return LE; } - (IS{SPC})?EQUALS?({SPC}TO)?/[[:space:]] { return '='; } + (IS{SPC})?EQUALS?({SPC}TO)?/[[:space:]] { + static char eq[] = "EQUAL"; + ydflval.string = yylval.string = eq; + return EQ; } {GREATER_THAN}{SPC}{OR_EQUAL}/[[:space:]] { return GE; } - {GREATER_THAN} { return '>'; } + {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; } @@ -1495,13 +1527,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; } @@ -1540,9 +1594,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; } @@ -1568,6 +1622,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; } @@ -1594,28 +1649,16 @@ USE({SPC}FOR)? { return USE; } FUNCTION { yy_push_state(function); return FUNCTION; } - SECTION{OSPC}[.]{SPC}/USE[[:space:]] { yylval.string = NULL; return SECTION; } + SECTION{OSPC}[.]+{SPC}/USE[[:space:]] { yylval.string = NULL; return SECTION; } - {NAME}{OSPC}[.]({SPC}(EJECT|SKIP[123]))*{SPC}EXIT{OSPC}/{DOTSEP} { + [.]+({SPC}(EJECT|SKIP[123]))*{SPC}EXIT{OSPC}/{DOTSEP} { // EXIT format-1 is a "continue" statement - yylval.string = xstrdup(yytext); - auto p = strchr(yylval.string, '.'); - assert(p); - assert( ISSPACE(p[1]) ); - *p = '\0'; - while( p > yylval.string && ISSPACE(p[-1]) ) { - *--p = '\0'; - } - - int token = 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); @@ -1643,16 +1686,17 @@ USE({SPC}FOR)? { return USE; } p += 2; while( ISSPACE(*p) ) p++; cbl_name_t name2; - std::transform( p, p + sizeof(name2), name2, - []( char ch ) { - switch(ch) { - case '-': - case '_': return ch; - default: - if( ISALNUM(ch) ) return ch; - } - return '\0'; - } ); + const char *pend = p + sizeof(name2); + char *pout = name2; + while( p < pend ) { + char ch = *p++; + if( ISALNUM(ch) || ch == '-' || ch == '_' ) { + *pout++ = ch; + } else { + *pout++ = '\0'; + break; + } + } symbol_elem_t *e = symbol_file(PROGRAM, name2); /* * For NAME IN FILENAME, we want the parser to handle it. @@ -1755,8 +1799,8 @@ USE({SPC}FOR)? { return USE; } if( elem->type == SymField ) { auto f = cbl_field_of(elem); if( f->type == FldLiteralA && f->has_attr(constant_e) ) { - type = date_time_fmt(f->data.initial); - yylval.string = xstrdup(f->data.initial); + type = date_time_fmt(f->data.original()); + yylval.string = xstrdup(f->data.original()); } } else { yylval.string = xstrdup(yytext); @@ -1777,126 +1821,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)); @@ -1944,7 +1990,8 @@ BASIS { yy_push_state(basis); return BASIS; } {STRING} { yy_pop_state(); yypush_buffer_state( yy_create_buffer(yyin, YY_BUF_SIZE) ); if( (yyin = cdftext::lex_open(yytext)) == NULL ) { - yywarn("could not open BASIS file '%s'", yytext); + cbl_message(yylloc, LexIncludeE, + "could not open BASIS file '%s'", yytext); yyterminate(); } } @@ -1955,7 +2002,8 @@ BASIS { yy_push_state(basis); return BASIS; } } <procedure_div>{ - EQUALS?{OSPC}/[(] { return '='; } + EQUALS?{OSPC}/[(] { ydflval.string = yylval.string = xstrdup(yytext); + return EQ; } {NAME}{OSPC}/[(] { /* If /{OSPC}, "dangerous trailing context" "*/ if( is_integer_token() ) return numstr_of(yytext); @@ -1991,7 +2039,7 @@ BASIS { yy_push_state(basis); return BASIS; } } return token; } - [.][[:blank:].]+ { return '.'; } + [.]+[[:blank:].]+ { return '.'; } } <exception>{ @@ -2011,7 +2059,7 @@ BASIS { yy_push_state(basis); return BASIS; } return symbol_file(PROGRAM, yytext)? FILENAME : NAME; } [[:blank:]]+ - \r?\n { yy_pop_state(); } + {EOL} { yy_pop_state(); } } <raising>{ @@ -2032,49 +2080,56 @@ BASIS { yy_push_state(basis); return BASIS; } if( include_debug() ) myless(7); } } - ^[ ]*>>{OSPC}IF { yy_push_state(cdf_state); return CDF_IF; } - ^[ ]*>>{OSPC}ELSE { return CDF_ELSE; } - ^[ ]*>>{OSPC}END-IF { return CDF_END_IF; } + ^[ ]*>>{OBLANK}IF { yy_push_state(cdf_state); return CDF_IF; } + ^[ ]*>>{OBLANK}ELSE { return CDF_ELSE; } + ^[ ]*>>{OBLANK}END-IF { return CDF_END_IF; } - ^[ ]*[$]{OSPC}IF { if( ! dialect_mf() ) { - dialect_error(yylloc, yytext, "mf"); - } + ^[ ]*[$]{OBLANK}IF { dialect_ok(yylloc, MfCdfDollar, yytext); yy_push_state(cdf_state); return CDF_IF; } - ^[ ]*[$]{OSPC}ELSE { if( ! dialect_mf() ) { - dialect_error(yylloc, yytext, "mf"); - } + ^[ ]*[$]{OBLANK}ELSE { dialect_ok(yylloc, MfCdfDollar, yytext); return CDF_ELSE; } - ^[ ]*[$]{OSPC}END { if( ! dialect_mf() ) { - dialect_error(yylloc, yytext, "mf"); - } + ^[ ]*[$]{OBLANK}END { dialect_ok(yylloc, MfCdfDollar, yytext); return CDF_END_IF; } - ^[ ]*[$]{OSPC}SET({SPC}CONSTANT)? { - if( ! dialect_mf() ) dialect_error(yylloc, yytext, "mf"); + ^[ ]*[$]{OBLANK}SET({SPC}CONSTANT)? { + dialect_ok(yylloc, MfCdfDollar, yytext); yy_push_state(cdf_state); return CDF_DEFINE; } - ^[ ]*>>{OSPC}EVALUATE { return CDF_EVALUATE; } - ^[ ]*>>{OSPC}WHEN { return CDF_WHEN; } - ^[ ]*>>{OSPC}END-EVALUATE { return CDF_END_EVALUATE; } + ^[ ]*>>{OBLANK}EVALUATE { return CDF_EVALUATE; } + ^[ ]*>>{OBLANK}WHEN { return CDF_WHEN; } + ^[ ]*>>{OBLANK}END-EVALUATE { return CDF_END_EVALUATE; } - ^[ ]*>>{OSPC}CALL-CONVENTION{SPC}C { return CALL_VERBATIM; } - ^[ ]*>>{OSPC}CALL-CONVENTION{SPC}COBOL { return CALL_COBOL; } - ^[ ]*>>{OSPC}CALL-CONVENTION{SPC}VERBATIM { return CALL_VERBATIM; } + ^[ ]*>>{OBLANK}CALL-CONVENTION{BLANK}C { return CALL_VERBATIM; } + ^[ ]*>>{OBLANK}CALL-CONVENTION{BLANK}COBOL { return CALL_COBOL; } + ^[ ]*>>{OBLANK}CALL-CONVENTION{BLANK}VERBATIM { return CALL_VERBATIM; } - ^[ ]*>>{OSPC}DEFINE { yy_push_state(cdf_state); return CDF_DEFINE; } - ^[ ]*>>{OSPC}DISPLAY { return CDF_DISPLAY; } - ^[ ]*>>{OSPC}TURN { yy_push_state(exception); return TURN; } - ^[ ]*>>{OSPC}COBOL-WORDS { yy_push_state(cobol_words); return COBOL_WORDS; } + ^[ ]*>>{OBLANK}DEFINE { yy_push_state(cdf_state); return CDF_DEFINE; } + ^[ ]*>>{OBLANK}DISPLAY { return CDF_DISPLAY; } + ^[ ]*>>{OBLANK}TURN { yy_push_state(exception); return TURN; } + ^[ ]*>>{OBLANK}COBOL-WORDS { yy_push_state(cobol_words); return COBOL_WORDS; } - ^[ ]*>>{OSPC}{NAME} { + ^[ ]*>>{OBLANK}SOURCE{BLANK}FORMAT { return SOURCE_FORMAT; } + + ^[ ]*>>{OBLANK}PUSH { return CDF_PUSH; } + ^[ ]*>>{OBLANK}POP { return CDF_POP; } + + ^[ ]*>>{OBLANK}{NAME} { error_msg(yylloc, "unknown CDF token: %s", yytext); } + OTHER { return OTHER; } OVERRIDE { return OVERRIDE; } PARAMETER { return PARAMETER_kw; } THRU { return THRU; } TRUE { return TRUE_kw; } + + ALL { return ALL; } + CALL-CONVENTION { return CALL_CONVENTION; } + COBOL-WORDS { return COBOL_WORDS; } + DEFINE { return CDF_DEFINE; } + SOURCE{BLANK}FORMAT { return SOURCE_FORMAT; } + } <cobol_words>{ @@ -2089,39 +2144,45 @@ BASIS { yy_push_state(basis); return BASIS; } } <*>{ - {PUSH_FILE} { - yy_set_bol(true); - auto top_file = cobol_lineno_save(); - if( top_file ) { - if( yy_flex_debug ) dbgmsg(" saving line %4d of %s", - yylineno, top_file); - } - // "\f#file push <name>": name starts at offset 13. - char *filename = xstrdup(yytext); - filename[yyleng - 1] = '\0'; // kill the trailing formfeed - filename += 12; - if( yytext[0] != '\f' ) { - dbgmsg("logic warning: filename was adjusted to %s", --filename); + {PUSH_FILE} { + yy_set_bol(true); + auto top_file = cobol_lineno(yylineno); + if( top_file ) { + if( yy_flex_debug ) dbgmsg(" saving line %4d of %s", + yylineno, top_file); + } + // "\f#file push <name>": name starts at offset 13. + char *filename = xstrdup(yytext); + filename[yyleng - 1] = '\0'; // kill the trailing formfeed + filename += 12; + if( yytext[0] != '\f' ) { + dbgmsg("logic warning: filename was adjusted to %s", + --filename); + } + input_file_status.enter(filename); + yylineno = 1; + reset_location(); + } + + {POP_FILE} { + yy_set_bol(true); + input_file_status.leave(); + yylineno = cobol_lineno(); } - input_file_status.enter(filename); - } - - {POP_FILE} { - yy_set_bol(true); - input_file_status.leave(); - } - {LINE_DIRECTIVE} { cobol_fileline_set(yytext); } + {LINE_DIRECTIVE} { + yylineno = cobol_fileline_set(yytext); + reset_location(); + } } <*>OR { return OR; } <*>AND { return AND; } -<*>{DOTSEP}[[:blank:].]+$ { return '.'; } -<*>[*/+-]{SPC}[+] { return *yytext; } +<*>{DOTSEP} { return '.'; } <*>[().=*/+&-] { return *yytext; } <*>[[:blank:]]+ -<*>\r?\n +<*>{EOL} <*>{ {COMMA} @@ -2132,48 +2193,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; } + 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; } @@ -2184,17 +2245,17 @@ 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; } + DEFAULT { yylval.number = 'D'; return DEFAULT; } DELETE { return DELETE; } DELIMITED { return DELIMITED; } DELIMITER { return DELIMITER; } @@ -2203,12 +2264,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; } @@ -2226,117 +2287,117 @@ 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 { ydflval.string = yylval.string = xstrdup(yytext); + return EQ; } + 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; } - PROGRAM { return PROGRAM; } + PROGRAM { return PROGRAM_kw; } PROGRAM-ID { return PROGRAM_ID; } PROPERTY { return PROPERTY; } PROTOTYPE { return PROTOTYPE; } QUOTES { return QUOTES; } - RAISE { return RAISE; } + RAISE { return RAISE; } RAISING { return RAISING; } RANDOM { return RANDOM; } - RD { return RD; } - READ { return READ; } + RD { return RD; } + READ { return READ; } RECORD { return RECORD; } RECORDS { return RECORDS; } REDEFINES { return REDEFINES; } - REEL { return REEL; } + REEL { return REEL; } REFERENCE { return REFERENCE; } RELATIVE { return RELATIVE; } RELEASE { return RELEASE; } @@ -2350,77 +2411,77 @@ BASIS { yy_push_state(basis); return BASIS; } REPORTS { return REPORTS; } REPOSITORY { return REPOSITORY; } RESERVE { return RESERVE; } - RESET { return RESET; } + RESET { return RESET; } RESUME { return RESUME; } RETURN { return RETURN; } RETURNING { return RETURNING; } REWIND { return REWIND; } REWRITE { return REWRITE; } - RF { return RF; } - RH { return RH; } - RIGHT { return RIGHT; } + RF { return RF; } + RH { return RH; } + RIGHT { return RIGHT; } ROUNDED { return ROUNDED; } - RUN { return RUN; } - SAME { return SAME; } + RUN { return RUN; } + SAME { return SAME; } SCREEN { return SCREEN; } - SD { return SD; } + SD { return SD; } SEARCH { return SEARCH; } - SECTION { return SECTION; } + SECTION { yylval.string = NULL; return SECTION; } SELECT { return SELECT; } SENTENCE { return SENTENCE; } SEPARATE { return SEPARATE; } SEQUENCE { return SEQUENCE; } SEQUENTIAL { return SEQUENTIAL; } - SET { return SET; } + SET { return SET; } SHARING { return SHARING; } - SIGN { return SIGN; } - SIZE { return SIZE; } - SORT { return SORT; } + SIGN { return SIGN; } + SIZE { return SIZE; } + SORT { return SORT; } SORT-MERGE { return SORT_MERGE; } SOURCE { return SOURCE; } - SPACE { return SPACE; } + SPACE { return SPACE; } SPACES { return SPACES; } SPECIAL-NAMES { return SPECIAL_NAMES; } STANDARD { return STANDARD; } STANDARD-1 { return STANDARD_1; } - START { return START; } + START { return START; } STATUS { return STATUS; } - STOP { return STOP; } + STOP { return STOP; } SUBTRACT { return SUBTRACT; } - SUM { return SUM; } + SUM { return SUM; } SUPPRESS { return SUPPRESS; } SYMBOLIC { return SYMBOLIC; } TALLYING { return TALLYING; } TERMINATE { return TERMINATE; } - TEST { return TEST; } - THAN { return THAN; } - THEN { return THEN; } - THRU { return THRU; } - TIME { return TIME; } - TIMES { return TIMES; } - TO { return TO; } - TOP { return TOP; } + TEST { return TEST; } + THAN { return THAN; } + THEN { return THEN; } + THRU { return THRU; } + TIME { return TIME; } + TIMES { return TIMES; } + TO { return TO; } + TOP { return TOP; } TRAILING { return TRAILING; } - TYPE { return TYPE; } + TYPE { return TYPE; } TYPEDEF { return TYPEDEF; } - UNIT { return UNIT; } - UNTIL { return UNTIL; } - UP { return UP; } - UPON { return UPON; } - USAGE { return USAGE; } - USE { return USE; } - USING { return USING; } - VALUE { return VALUE; } + UNIT { return UNIT; } + UNTIL { return UNTIL; } + UP { return UP; } + UPON { return UPON; } + USAGE { return USAGE; } + USE { return USE; } + USING { return USING; } + VALUE { return VALUE; } VARYING { return VARYING; } - WHEN { return WHEN; } - WITH { return WITH; } + WHEN { return WHEN; } + WITH { return WITH; } WORKING-STORAGE { return WORKING_STORAGE; } - WRITE { return WRITE; } + WRITE { return WRITE; } ZERO | ZEROES | - ZEROS { return ZERO; } + ZEROS { return ZERO; } } <*>{ @@ -2457,28 +2518,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..e75bb38 100644 --- a/gcc/cobol/scan_ante.h +++ b/gcc/cobol/scan_ante.h @@ -149,7 +149,7 @@ numstr_of( const char string[], radix_t radix = decimal_e ) { } auto nx = std::count_if(input, p, fisdigit); if( 36 < nx ) { - error_msg(yylloc, "significand of %s has more than 36 digits (%zu)", input, nx); + error_msg(yylloc, "significand of %s has more than 36 digits (%ld)", input, (long)nx); return NO_CONDITION; } @@ -159,11 +159,11 @@ numstr_of( const char string[], radix_t radix = decimal_e ) { // exponent is implementor-defined." (We allow 9999.) nx = std::count_if(p, eoinput, fisdigit); if( 4 < nx ) { - error_msg(yylloc, "exponent %s more than 4 digits", ++p); + error_msg(yylloc, "exponent %qs more than 4 digits", ++p); return NO_CONDITION; } if( eoinput != std::find(p, eoinput, symbol_decimal_point()) ) { - error_msg(yylloc, "exponent includes decimal point", ++p); + error_msg(yylloc, "exponent %qs includes decimal point", ++p); return NO_CONDITION; } @@ -187,7 +187,7 @@ numstr_of( const char string[], radix_t radix = decimal_e ) { } } if( 1 < std::count(input, eoinput, symbol_decimal_point()) ) { - error_msg(yylloc, "invalid numeric literal", ++p); + error_msg(yylloc, "invalid numeric literal %qs", ++p); return NO_CONDITION; } @@ -214,7 +214,11 @@ struct cdf_status_t { const char *filename; int token; bool parsing; - cdf_status_t( int token = 0, bool parsing = true ) + cdf_status_t() + : lineno(yylineno), filename(cobol_filename()) + , token(0), parsing(true) + {} + cdf_status_t( int token, bool parsing ) : lineno(yylineno), filename(cobol_filename()) , token(token), parsing(parsing) {} @@ -291,7 +295,7 @@ static class parsing_status_t : public std::stack<cdf_status_t> { void splat() const { int i=0; for( const auto& status : c ) { - yywarn( "%4d\t%s", ++i, status.str() ); + dbgmsg( "%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; @@ -312,34 +316,29 @@ 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", - keyword_str(token), boolalpha(parsing.on()), parsing.size()); - parsing.splat(); - } + dbgmsg("%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", - keyword_str(CDF_ELSE), boolalpha(parsing.on())); - } + dbgmsg("%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()); - parsing.splat(); - } + dbgmsg("%s: parsing now %s, depth %zu", + keyword_str(CDF_END_IF), boolalpha(parsing.on()), + parsing.size()); + parsing.splat(); } @@ -351,6 +350,10 @@ static void level_found() { if( scanner_normal() ) parsing.need_level(false); } +/* + * Trim the scanned location by the amount about to re-scanned. + * Must be a macro because it expands yyless. + */ #define myless(N) \ do { \ auto n(N); \ @@ -368,8 +371,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 +385,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 +401,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 +414,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,14 +476,16 @@ 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); + yylloc.last_line -= int(nline); + gcc_assert( yylloc.first_line <= yylloc.last_line ); char *p = static_cast<char*>(memrchr(rescan.p, '\n', rescan.size())); yylloc.last_column = rescan.pend - ++p; return; @@ -473,7 +513,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 +523,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 +551,116 @@ 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; // zero means capacity depends on PICTURE + bool signable; +}; +static const std::map <std::string, bint_t > binary_integers { + { "BINARY", { COMPUTATIONAL, FldNumericBinary, 0, false } }, + { "COMP", { COMPUTATIONAL, FldNumericBinary, 0, false } }, + { "COMPUTATIONAL", { COMPUTATIONAL, FldNumericBinary, 0, false } }, + { "COMP-4", { COMPUTATIONAL, FldNumericBinary, 0, false } }, + { "COMPUTATIONAL-4", { COMPUTATIONAL, FldNumericBinary, 0, false } }, + + { "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 } }, + + { "COMP-5", { COMPUTATIONAL, FldNumericBin5, 0, false } }, + { "COMPUTATIONAL-5", { COMPUTATIONAL, FldNumericBin5, 0, false } }, + { "COMP-X", { COMPUTATIONAL, FldNumericBin5, 0xFF, false } }, + { "COMPUTATIONAL-X", { COMPUTATIONAL, FldNumericBin5, 0xFF, false } }, + + { "COMP-1", { COMPUTATIONAL, FldFloat, 4, false } }, + { "COMPUTATIONAL-1", { COMPUTATIONAL, FldFloat, 4, false } }, + { "FLOAT-BINARY-32", { COMPUTATIONAL, FldFloat, 4, false } }, + { "FLOAT-SHORT", { COMPUTATIONAL, FldFloat, 4, false } }, + + { "COMP-2", { COMPUTATIONAL, FldFloat, 8, false } }, + { "COMPUTATIONAL-2", { COMPUTATIONAL, FldFloat, 8, false } }, + { "FLOAT-BINARY-64", { COMPUTATIONAL, FldFloat, 8, false } }, + { "FLOAT-LONG", { COMPUTATIONAL, FldFloat, 8, false } }, + { "FLOAT-BINARY-128", { COMPUTATIONAL, FldFloat, 16, false } }, + { "FLOAT-EXTENDED", { COMPUTATIONAL, FldFloat, 16, false } }, + + { "COMP-6", { COMPUTATIONAL, FldPacked, 0, false } }, + { "COMPUTATIONAL-6", { COMPUTATIONAL, FldPacked, 0, false } }, +}; + +static int +binary_integer_usage( const char name[]) { + // uname can't be cbl_name_t, because at this point name[] might have more + // than sizeof(cbl_name_t) characters. The length check comes later. + char *uname = xstrdup(name); + std::transform(name, name + strlen(name), uname, ftoupper); + + dbgmsg("%s:%d: checking %s in %zu keyword_aliases", + __func__, __LINE__, uname, + keyword_aliases.size() ); + + 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 ); + free(uname); + return p->second.token; +} + +static void +verify_ws( const YYLTYPE& loc, const char [] /* input[] */, char ch ) { + if( ! fisspace(ch) ) { + dialect_ok(loc, LexSeparatorE, "missing separator space"); + } +} +#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; @@ -517,7 +668,7 @@ level_of( const char input[] ) { if( input[0] == '0' ) input++; if( 1 != sscanf(input, "%u", &output) ) { - yywarn( "%s:%d: invalid level '%s'", __func__, __LINE__, input ); + cbl_internal_error( "%s:%d: invalid level '%s'", __func__, __LINE__, input ); } return output; @@ -543,6 +694,387 @@ picset( int token ) { return token; } +/** +## Script and data to produce picture_t::followers. +## Based on ISO Table 10. +#! /usr/bin/awk -f + +BEGIN { + str = "B0/ , . + +- +- CR/DB cs cs Z* Z* + + cs cs 9 AX S V P P 1 N E" + split(str, cols) +} + +$1 ~ /CR|DB|cs/ { next } + +0 && !nlines++ { + for( i=0; i < length(cols); i++ ) { + print i, cols[i], "'" $i "'" + } +} + +$field == "x" { + if( ! nout++ ) { + printf "%2d: %5s: \"", field, cols[field - 1] + } + + gsub(/^ +| +$/, "", $1) + printf "%s", $1 +} + +END { + if( ! nout++ ) { + printf "%2d: %5s: \"", field, cols[field - 1] + } + print "\"" +} + +B x x x - x - - x - x x x x x x x x - x - x - x +0 x x x - x - - x - x x x x x x x x - x - x - x +/ x x x - x - - x - x x x x x x x x - x - x - x +, x x x - x - - x - x x x x x x x - - x - x +. x x - - x - - x - x - x - x - x ++ - - - - - - - - - - - - - - - - - - - - - - - x ++ +– ++ x x x - - - - x x x x - - x x x - - x x x +CR x x x - - - - x x x x - - x x x - - x x x +DB x x x - - - - x x x x - - x x x - - x x x +cs - - - - x +cs x x x - x - - - - x x - - - - x - - x x x + +Z x x - - x - - x - x +* x x - - x - - x - x +Z x x x - x - - x - x x - - - - - - - x - x +* x x x - x - - x - x x - - - - - - - x - x ++ x x - - - - - x - - - x +– x x - - - - - x - - - x ++ x x x - - - - x - - - x x - - - - - x +– x x x - - - - x - - - x x - - - - - x +cs x x - - x - - - - - - - - x +cs x x x - x - - - - - - - - x x - - - x + +9 x x x x x - - x - x - x - x - x x x x - x - - x +A x - - - - - - - - - - - - - - x x +X x - - - - - - - - - - - - - - x x +S +V x x - - x - - x - x - x - x - x - x - x +P x x - - x - - x - x - x - x - x - x - x +P - - - - x - - x - - - - - - - - - x x - x +1 - - - - - - - - - - - - - - - - - - - - - x +N x - - - - - - - - - - - - - - - - - - - - - x +E x x x - x - - - - - - - - - - x +**/ + +class picture_t { + static const char dot = '.', comma = ','; + + typedef std::vector<std::string> followings_t; + static const std::map <char, followings_t> followers; + + const char * const begin; + const char *p, *pend; + size_t pos; + struct exclusions_t { // Nonzero if set, > 1 is false. + // crdb means CR/DB or +/-. + // pluses means 2 or more consecutive '+'. + // minuses means 2 or more consecutive '-'. + // "21) The symbol 'Z' and the symbol '*' are mutually exclusive " + // stars means '*' or Z. + unsigned short int crdb, currency, dot, pluses, minuses, stars, zzz; + exclusions_t() + : crdb(0), currency(0), dot(0), pluses(0), minuses(0), stars(0) + {} + } exclusions; + YYLTYPE loc; + + bool is_crdb() const { // input must be uppercase for CR/DB + if( p[0] == 'C' || p[0] == 'D' ) { + char input[3] = { p[0], p[1] }; + return ( 0 == strcmp(input, "CR") || 0 == strcmp(input, "DB") ); + } + return false; + } + + const char * match_paren( const char *paren ) const { + gcc_assert(paren[0] == '('); // start with opening paren + paren = std::find_if( paren, pend, + []( char ch ) { + return ch == '(' || ch == ')'; + } ); + if( *paren == '(' ) return nullptr; // no nesting + if( paren == pend ) return nullptr; + return ++paren; + } + + const char * next_not( char ch ) const { + return std::find_if( p, pend, + [ch = TOUPPER(ch)]( char next ) { + return ch != next; + } ); + } + + const char * valid_next( const char *p, const std::string& valid ) const { + if( p == pend || p + 1 == pend ) return pend; + if( p[1] == '(' ) { + return match_paren(++p); + } + auto pv = std::find(valid.begin(), valid.end(), TOUPPER(p[1])); + return pv != valid.end()? ++p : nullptr; + } + const char * valid_next( const char *p, + bool first = true, char ch = '\0' ) const { + if( p == pend || p + 1 == pend ) return pend; + if( p[0] == '(' ) { + if( (p = match_paren(p)) == nullptr ) return nullptr; + } + if( p[0] == '(' ) return nullptr; // consecutive parentheses + + int index = first? 0 : 1; + if( !ch ) ch = *p; // use current character unless overridden + auto valid = followers.find(TOUPPER(ch)); + if( valid == followers.end() ) { + YYLTYPE loc(yylloc); + loc.first_column += int(p - begin); + error_msg( loc, "PICTURE: strange character %qc, giving up", ch ); + return nullptr; + } + return valid_next(p, valid->second[index]); + } + + const char * start() { // start modifies exclusions, but not p + auto pnext = p; + + switch(TOUPPER(p[0])) { + case comma: case dot: + // use decimal_is_comma() + // 4: .: "B0/,+Z*+-9E" + exclusions.dot++; + pnext = valid_next(p, "B0/,+Z*+-9E"); + break; + case '+': case '-': + // 6: +-: "B0/,.Z*Z*9VPPE" + exclusions.crdb++; + pnext = next_not(p[0]); + if( p + 1 < pnext ) { + exclusions.pluses++; + } + pnext = valid_next(--pnext, "B0/,.Z*Z*9VPPE"); + break; + case 'Z': case '*': + exclusions.stars++; + pnext = next_not(p[0]); + break; + case 'S': + // 19: S: "9VP" + pnext = valid_next(p, "9VP"); + break; + } + + /* + * "For fixed editing sign control, the currency symbol, when used, shall + * be either the leftmost symbol in character-string-1, optionally preceded + * by one of the symbols '+' or '-' " + */ + if( pnext ) { + if( p == pnext || p[0] == '+' || p[0] == '-' ) { + if( symbol_currency(*pnext) ) { + exclusions.currency++; + pnext = next_not(*pnext); + pnext = valid_next(--pnext, true, '$'); + } + } + } + + return pnext; + } + + const char * next() { // modify state; do not modify position + auto pnext = p; + auto loc(picture_t::loc); + loc.first_column += int(p - begin); + + if( is_crdb() ) { + if( exclusions.crdb++ ) { + error_msg( loc, "PICTURE: CR/DB and %c/%c may appear only once", '+', '-' ); + return nullptr; + } + if( p + 2 != pend ) { + error_msg( loc, "PICTURE: CR/DB must appear at the end" ); + return nullptr; + } + return pend; + } + + if( symbol_currency(p[0]) ) { + if( false && exclusions.currency++ ) { // not enforced + error_msg( loc, "PICTURE: CURRENCY SYMBOL sequence may appear at most once" ); + return nullptr; + } + return valid_next(p, ! exclusions.dot, '$'); + } + + switch(TOUPPER(p[0])) { + case '(': + return match_paren(p); + break; + case 'B': case '0': case '/': + pnext = valid_next(p); + break; + case comma: + if( decimal_is_comma() ) { + if( exclusions.dot++ ) { + error_msg( loc, "PICTURE: %qc: may appear at most once", p[0] ); + return nullptr; + } + pnext = valid_next(p, true, dot); + } else { + pnext = valid_next(p); + } + break; + case dot: + if( p + 1 == pend ) { + pnext = pend; + } else { + if( decimal_is_comma() ) { + pnext = valid_next(p, true, comma ); + } else { + if( exclusions.dot++ ) { + error_msg( loc, "PICTURE: %qc: may appear at most once", p[0] ); + return nullptr; + } + pnext = valid_next(p); + } + } + break; + + case '+': case '-': + // 7 is trailing sign; 13 & 14 are numeric. Leading sign handled by start(). + if( p + 1 == pend ) { + if( exclusions.crdb++ ) { + error_msg( loc, "PICTURE: %c/%c may appear at most once as a sign", '+', '-' ); + return nullptr; + } + pnext = pend; + } else { + pnext = next_not(p[0]); + if( p + 1 < pnext ) { + if( false && exclusions.pluses++ ) { // not enforced + error_msg( loc, "PICTURE: %qc: sequence may appear at most once", p[0] ); + return nullptr; + } + } + pnext = valid_next(pnext, ! exclusions.dot); + } + break; + + case 'Z': case '*': + if( false && exclusions.stars++ ) { // not enforced + error_msg( loc, "PICTURE: %qc: sequence may appear at most once", p[0] ); + return nullptr; + } + if( (pnext = next_not(p[0])) == nullptr ) return pnext; + pnext = valid_next(pnext, ! exclusions.dot); + break; + case 'P': + pnext = valid_next(pnext, ! exclusions.dot); + break; + case '9': + case 'A': case 'X': + case 'V': + case '1': + case 'N': + pnext = valid_next(p); + break; + case 'E': + pnext = valid_next(p, "+9"); + if( pnext && *pnext == '+' ) { + pnext = valid_next(p, "9"); + } + break; + default: + error_msg( loc, "PICTURE: %qc: invalid character", p[0] ); + return nullptr; + } + return pnext; + } + + public: + picture_t( const char *p, int len ) + : begin(p) + , p(p), pend(p + len) + , loc(yylloc) + { + assert(TOUPPER(*p) == 'P'); // as in PICTURE (or PICTURE IS) + // move p to start of picture string + while( (p = std::find_if(p, pend, fisspace)) != pend ) { + this->p = p = std::find_if(p, pend, + []( char ch ) { return ! fisspace(ch); } ); + } + assert(this->p != pend); + pos = this->p - begin; + } + + bool is_valid() { + if( !p ) return false; + if( (p = start()) == nullptr ) { + return false; + } + + while( p && p < pend) { + p = next(); + } + return p == pend; + } + + int starts_at() const { return pos; } +}; + +/* + * The Followers map gives 1 or 2 lists of valid characters following a + * character, the one in the key. If there are two lists, the correct one is + * determined by the caller based on the state of the picture string, i.e., + * what has been seen before. + */ +const std::map <char, picture_t::followings_t> picture_t::followers { + /* B0/ */ { 'B', {"B0/,.Z*+-9AXVPNE" } }, + /* B0/ */ { '0', {"B0/,.Z*+-9AXVPNE" } }, + /* B0/ */ { '/', {"B0/,.Z*+-9AXVPNE" } }, + /* , */ { ',', {"B0/,.Z*+-9VPE"} }, + /* . */ { '.', {"B0/,Z*+-9E"} }, + /* + { '+', "9" }, */ + /* +- */ { '+', {"B0/,.Z*9VPE", "" } }, + /* +- */ { '-', {"B0/,.Z*9VPE", "" } }, + /* CR/DB { 'C', "" }, */ + /* cs { 'c', "B0/,.Z*+-9VP" }, */ + /* cs { 'c', "+" }, */ + /* Z* */ { 'Z', {"B0/,.+Z*9VP", "B0/,+Z*"} }, + /* Z* */ { '*', {"B0/,.+Z*9VP", "B0/,+Z*"} }, + /* + */ { '+', {"B0/,.+-9VP", "B0/,+-"} }, + /* cs */ { '$', {"B0/,.+9VP", "B0/,+"} }, + /* 9 */ { '9', {"B0/,.+9AXVPE"} }, + /* AX */ { 'A', {"B0/9AX"} }, + /* AX */ { 'X', {"B0/9AX"} }, + /* S */ { 'S', {"9VP"} }, + /* V */ { 'V', {"B0/,+Z*+-9P"} }, + /* P */ { 'P', {"+VP", "B0/,+Z*9P"} }, + /* 1 */ { '1', {"1"} }, + /* N */ { 'N', {"B0/N"} }, + /* E */ { 'E', {"+9"} }, +}; + +/* + * Although picture_t::is_valid return a bool, it's not used. The validation + * routines emit messages where the error is detected. The entire string is + * subsequently parsed by the parser, which might otherwise accept an invalid + * string, but will usually emit a message of its own. + */ +static int +validate_picture() { + picture_t picture(yytext, yyleng); + picture.is_valid(); + return picture.starts_at(); +} + static inline bool is_integer_token( int *pvalue = NULL ) { int v, n = 0; @@ -559,7 +1091,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 +1165,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 +1179,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 +1213,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\"", + cbl_internal_error("%s:%d: invalid symbol type %s for symbol %qs", __func__, __LINE__, cbl_field_type_str(type), name); return NAME; } @@ -694,40 +1230,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 @@ -738,8 +1245,14 @@ integer_of( const char input[], bool is_hex = false) { if( input[0] == '0' ) input++; if( 1 != sscanf(input, fmt, &output) ) { - yywarn( "%s:%d: invalid integer '%s'", __func__, __LINE__, input ); + cbl_internal_error( "%s:%d: invalid integer '%s'", __func__, __LINE__, input ); } return output; } + + + + + + diff --git a/gcc/cobol/scan_post.h b/gcc/cobol/scan_post.h index dabb168..cb729b3 100644 --- a/gcc/cobol/scan_post.h +++ b/gcc/cobol/scan_post.h @@ -33,13 +33,14 @@ start_condition_str( int sc ) { const char *state = "???"; switch(sc) { case INITIAL: state = "INITIAL"; break; - case author_state: state = "author_state"; break; + case addr_of: state = "addr_of"; 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 +63,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,12 +115,13 @@ 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); + cbl_internal_error("%s:%d: %s: %s", __func__, __LINE__, + keyword_str(p->token), msg); } } } @@ -157,6 +159,8 @@ is_cdf_token( int token ) { case CDF_DISPLAY: case CDF_IF: case CDF_ELSE: case CDF_END_IF: case CDF_EVALUATE: case CDF_WHEN: case CDF_END_EVALUATE: + case CDF_PUSH: + case CDF_POP: return true; case CALL_COBOL: case CALL_VERBATIM: @@ -258,13 +262,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. @@ -291,12 +294,12 @@ prelex() { if( YY_START == field_state && level_needed() ) { switch( token ) { case NUMSTR: - if( yy_flex_debug ) yywarn("final token is NUMSTR"); + dbgmsg("final token is NUMSTR"); yylval.number = level_of(yylval.numstr.string); token = LEVEL; break; case YDF_NUMBER: - if( yy_flex_debug ) yywarn("final token is YDF_NUMBER"); + dbgmsg("final token is YDF_NUMBER"); yylval.number = ydflval.number; token = LEVEL; break; @@ -373,7 +376,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", @@ -399,3 +402,12 @@ yylex(void) { return token; } + +/* + * Token name<->string utilities + */ + +// tokens.h is generated as needed from parse.h with tokens.h.gen +current_tokens_t::tokenset_t::tokenset_t() { +#include "token_names.h" +}; diff --git a/gcc/cobol/show_parse.h b/gcc/cobol/show_parse.h index ad26584..a5f1467 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 @@ -134,17 +140,23 @@ extern bool cursor_at_sol; fprintf(stderr, "%s", (b).field->name); \ if( (b).field->type == FldLiteralA || (b).field->type == FldLiteralN ) \ { \ - fprintf(stderr, " \"%s\"", (b).field->data.initial); \ + size_t nbytes; \ + const char *literal = __gg__iconverter((b).field->codeset.encoding, \ + DEFAULT_SOURCE_ENCODING, \ + (b).field->data.initial, \ + strlen((b).field->data.initial), \ + &nbytes); \ + fprintf(stderr, " \"%s\"", literal); \ } \ else \ { \ 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) \ { \ @@ -170,11 +182,21 @@ extern bool cursor_at_sol; } \ else \ { \ - fprintf(stderr, " %p:%s (%s)", (void*)b, b->name, b->type_str()); \ + fprintf(stderr, " %p:%s (%s)", static_cast<void*>(b), b->name, b->type_str()); \ } \ show_parse_sol = false; \ } while(0); +// Use this version when b is known to be valid. This is necessary to quiet +// cppcheck nullPointerRedundantCheck warnings +#define SHOW_PARSE_LABEL_OK(a, b) \ + do \ + { \ + fprintf(stderr, "%s", a); \ + fprintf(stderr, " %p:%s (%s)", static_cast<void*>(b), b->name, b->type_str()); \ + show_parse_sol = false; \ + } while(0); + #define TRACE1 if(bTRACE1) #define TRACE1_HEADER do \ { \ @@ -205,6 +227,7 @@ extern bool cursor_at_sol; #define TRACE1_FIELD_VALUE(a, field, b) \ do \ { \ + gcc_assert(field); \ cursor_at_sol=false; \ if ( field->type == FldConditional ) \ { \ @@ -331,13 +354,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, " "); \ } \ @@ -417,31 +440,51 @@ extern bool cursor_at_sol; } while(0); // Use CHECK_FIELD when a should be non-null, and a->var_decl_node also should -// by non-null: -#define CHECK_FIELD(a) \ - do{ \ - if(!a) \ - { \ - yywarn("%s(): parameter " #a " is NULL", __func__); \ - gcc_unreachable(); \ - } \ - if( !a->var_decl_node && a->type != FldConditional && a->type != FldLiteralA) \ - { \ - yywarn("%s() parameter " #a " is variable %s<%s> with NULL var_decl_node", \ - __func__, \ - a->name, \ - cbl_field_type_str(a->type) ); \ - gcc_unreachable(); \ - } \ - }while(0); - -#define CHECK_LABEL(a) \ - do{ \ - if(!a) \ - { \ - yywarn("%s(): parameter " #a " is NULL", __func__); \ - gcc_unreachable(); \ - } \ +// by non-null. (The useless calls to abort() are because cppcheck doesn't +// understand that gcc_unreachable doesn't return); + +// Use this after doing any SHOW_PARSE stuff, to avoid cppcheck complaints +// about nullPointerRedundantCheck +#define CHECK_FIELD(a) \ + do { \ + if(!a) \ + { \ + cbl_internal_error("%s: parameter %<" #a "%> is NULL", __func__); \ + } \ + if( !a->var_decl_node ) \ + { \ + cbl_internal_error("%s: parameter %<" #a "%> is variable " \ + "%s<%s> with NULL %<var_decl_node%>", \ + __func__, \ + a->name, \ + cbl_field_type_str(a->type) ); \ + } \ + } while(0); + +// This version is a bit more lax, for special cases +#define CHECK_FIELD2(a) \ + do { \ + if(!a) \ + { \ + cbl_internal_error("%s: parameter %<" #a "%> is NULL", __func__); \ + } \ + if( !a->var_decl_node && a->type != FldConditional && a->type != FldLiteralA) \ + { \ + cbl_internal_error("%s: parameter %<" #a "%> is variable " \ + "%s<%s> with NULL %<var_decl_node%>", \ + __func__, \ + a->name, \ + cbl_field_type_str(a->type) ); \ + } \ + } while(0); + + +#define CHECK_LABEL(a) \ + do{ \ + if(!a) \ + { \ + cbl_internal_error("%s: parameter %<" #a "%> is NULL", __func__); \ + } \ }while(0); #ifdef INCORPORATE_ANALYZER @@ -453,7 +496,7 @@ class ANALYZE int level; inline static int analyze_level=1; public: - ANALYZE(const char *func_) : func(func_) + ANALYZE(const char *func_) : func(func_) // cppcheck-suppress noExplicitConstructor { level = 0; if( getenv("Analyze") ) @@ -497,10 +540,11 @@ class ANALYZE } }; #else +// cppcheck-suppress ctuOneDefinitionRuleViolation class ANALYZE { public: - ANALYZE(const char *) + explicit ANALYZE(const char *) { } ~ANALYZE() diff --git a/gcc/cobol/structs.cc b/gcc/cobol/structs.cc index 39c8a42..2b13b1f 100644 --- a/gcc/cobol/structs.cc +++ b/gcc/cobol/structs.cc @@ -55,7 +55,6 @@ #include "cobol-system.h" #include "coretypes.h" #include "tree.h" -#define HOWEVER_GCC_DEFINES_TREE 1 #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" #include "util.h" @@ -158,7 +157,6 @@ tree cblc_field_pp_type_node; tree cblc_file_type_node; tree cblc_file_p_type_node; tree cblc_goto_type_node; -tree cblc_int128_type_node; // The following functions return type_decl nodes for the various structures @@ -178,16 +176,18 @@ 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 signed char rdigits; // Digits to the right of the decimal point. 3 for 99v999 + cbl_encoding_t encoding; // Same as cbl_field_t::codeset::encoding + int alphabet; // Same as cbl_field_t::codeset::language } cblc_field_t; */ tree retval = NULL_TREE; retval = gg_get_filelevel_struct_type_decl( "cblc_field_t", - 16, + 17, UCHAR_P, "data", SIZE_T, "capacity", SIZE_T, "allocated", @@ -198,12 +198,13 @@ 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", SCHAR, "rdigits", - INT, "dummy"); // Needed to make it an even number of 32-bit ints + INT, "encoding", + INT, "alphabet"); retval = TREE_TYPE(retval); return retval; @@ -218,6 +219,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 @@ -246,14 +248,17 @@ typedef struct cblc_file_t int recent_char; // This is the most recent char sent to the file int recent_key; cblc_file_prior_op_t prior_op; + int encoding; // Actually cbl_encoding_t + int alphabet; // Actually cbl_encoding_t int dummy // We need an even number of INT } cblc_file_t; */ tree retval = NULL_TREE; retval = gg_get_filelevel_struct_type_decl( "cblc_file_t", - 30, + 33, CHAR_P, "name", + SIZE_T, "symbol_table_index", CHAR_P, "filename", FILE_P, "file_pointer", cblc_field_p_type_node, "default_record", @@ -282,39 +287,13 @@ typedef struct cblc_file_t INT, "recent_char", INT, "recent_key", INT, "prior_op", + INT, "encoding", // Actually cbl_encoding_t + INT, "alphabet", INT, "dummy"); retval = TREE_TYPE(retval); return retval; } -static tree -create_cblc_int128_t() - { - /* - // GCC-13 can't initialize __int64 variables, which is something we need to - // be able to do. So, I created this union. The array can be initialized, - // and thus we do an end run around the problem. Annoying, but not fatally - // so. - - typedef union cblc_int128_t - { - unsigned char array16[16]; - __uint128 uval128; - __int128 sval128; - } cblc_int128_t; - */ - tree retval = NULL_TREE; - tree array_type = build_array_type_nelts(UCHAR, 16); - retval = gg_get_filelevel_union_type_decl( - "cblc_int128_t", - 3, - array_type, "array16" , - UINT128, "uval128" , - INT128, "sval128" ); - retval = TREE_TYPE(retval); - return retval; - } - void create_our_type_nodes() { @@ -327,7 +306,6 @@ 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); - cblc_int128_type_node = create_cblc_int128_t(); } } diff --git a/gcc/cobol/structs.h b/gcc/cobol/structs.h index 618d8f0..47a78b4 100644 --- a/gcc/cobol/structs.h +++ b/gcc/cobol/structs.h @@ -55,7 +55,6 @@ 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 cblc_goto_type_node; -extern GTY(()) tree cblc_int128_type_node; extern void create_our_type_nodes(); diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index 38c7a2e..a177fcd 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -28,8 +28,15 @@ * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ +// cppcheck-suppress-file duplicateBreak + +#include "config.h" #include <fstream> // Before cobol-system because it uses poisoned functions #include "cobol-system.h" + +#include "coretypes.h" +#include "tree.h" + #include <search.h> #include <iconv.h> #include "../../libgcobol/ec.h" @@ -40,6 +47,7 @@ #include "inspect.h" #include "../../libgcobol/io.h" #include "genapi.h" +#include "../../libgcobol/charmaps.h" #pragma GCC diagnostic ignored "-Wunused-result" #pragma GCC diagnostic ignored "-Wmissing-field-initializers" @@ -51,7 +59,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) {} @@ -89,7 +97,7 @@ static struct symbol_table_t { exception_condition, very_true, very_false; registers_t() { file_status = linage_counter = return_code = - exception_condition = very_true = very_false = 0; + exception_condition = very_true = very_false = 0; } } registers; @@ -131,11 +139,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"); } @@ -155,8 +161,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)); } /* @@ -224,6 +230,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) @@ -245,127 +257,21 @@ cbl_ffi_arg_t( cbl_ffi_crv_t crv, if( refer && refer != refer->empty() ) delete refer; } -#define ERROR_FIELD(F, ...) \ - do{ \ - auto loc = symbol_field_location(field_index(F)); \ - error_msg(loc, __VA_ARGS__); \ +#define ERROR_FIELD(F, ...) \ + do{ \ + auto loc = symbol_field_location(field_index(F)); \ + error_msg(loc, __VA_ARGS__); \ } 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(); -static const struct cbl_field_t empty_float = { - 0, FldFloat, FldInvalid, - intermediate_e, - 0, 0, 0, nonarray, 0, "", - 0, cbl_field_t::linkage_t(), - {16, 16, 32, 0, NULL}, NULL }; - -static const struct cbl_field_t empty_comp5 = { - 0, FldNumericBin5, FldInvalid, - signable_e | intermediate_e, - 0, 0, 0, nonarray, 0, "", - 0, cbl_field_t::linkage_t(), - {16, 16, MAX_FIXED_POINT_DIGITS, 0, NULL}, NULL }; - #if 0 # define CONSTANT_E constant_e #else # define CONSTANT_E intermediate_e #endif -static struct cbl_field_t empty_literal = { - 0, FldInvalid, FldInvalid, CONSTANT_E, - 0, 0, 0, nonarray, 0, "", - 0, cbl_field_t::linkage_t(), - {}, NULL }; - -static const struct cbl_field_t empty_conditional = { - 0, FldConditional, FldInvalid, intermediate_e, - 0, 0, 0, nonarray, 0, "", - 0, cbl_field_t::linkage_t(), - {}, NULL }; - - -/** - * Debug register record - 01 DEBUG-ITEM. - 02 DEBUG-LINE PIC X(6). - 02 FILLER PIC X VALUE SPACE. - 02 DEBUG-NAME PIC X(30). - 02 FILLER PIC X VALUE SPACE. - 02 DEBUG-SUB-1 PIC S9999 SIGN IS LEADING SEPARATE CHARACTER. - 02 FILLER PIC X VALUE SPACE. - 02 DEBUG-SUB-2 PIC S9999 SIGN IS LEADING SEPARATE CHARACTER. - 02 FILLER PIC X VALUE SPACE. - 02 DEBUG-SUB-3 PIC S9999 SIGN IS LEADING SEPARATE CHARACTER. - 02 FILLER PIC X VALUE SPACE. - 02 DEBUG-CONTENTS PIC X(76). - **/ - -static cbl_field_t debug_registers[] = { - { 0, FldGroup, FldInvalid, global_e, 0,0,1, nonarray, 0, - "DEBUG-ITEM", 0, {}, {132,132,0,0, NULL}, NULL }, - { 0, FldAlphanumeric, FldInvalid, global_e, 0,0,2, nonarray, 0, - "DEBUG-LINE", 0, {}, {6,6,0,0, " "}, NULL }, - { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0, - "FILLER", 0, {}, {1,1,0,0, " "}, NULL }, - { 0, FldAlphanumeric, FldInvalid, global_e, 0,0,2, nonarray, 0, - "DEBUG-NAME", 0, {}, {30,30,0,0, NULL}, NULL }, - { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0, - "FILLER", 0, {}, {1,1,0,0, " "}, NULL }, - { 0, FldNumericDisplay, FldInvalid, signable_e | global_e | leading_e | separate_e, 0,0,2, nonarray, 0, - "DEBUG-SUB-1", 0, {}, {5,5,3,0, NULL}, NULL }, - { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0, - "FILLER", 0, {}, {1,1,0,0, " "}, NULL }, - { 0, FldNumericDisplay, FldInvalid, signable_e | global_e | leading_e | separate_e, 0,0,2, nonarray, 0, - "DEBUG-SUB-2", 0, {}, {5,5,3,0, NULL}, NULL }, - { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0, - "FILLER", 0, {}, {1,1,0,0, " "}, NULL }, - { 0, FldNumericDisplay, FldInvalid, signable_e | global_e | leading_e | separate_e, 0,0,2, nonarray, 0, - "DEBUG-SUB-3", 0, {}, {5,5,3,0, NULL}, NULL }, - { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0, - "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 }, -}; class group_size_t { size_t size; @@ -380,30 +286,14 @@ class group_size_t { enum { constq = constant_e | quoted_e }; -static cbl_field_t special_registers[] = { - { 0, FldNumericDisplay, FldInvalid, 0, 0, 0, 0, nonarray, 0, "_FILE_STATUS", - 0, {}, {2,2,2,0, NULL}, NULL }, - { 0, FldNumericBin5, FldInvalid, 0, 0, 0, 0, nonarray, 0, "UPSI-0", - 0, {}, {2,2,4,0, NULL}, NULL }, - { 0, FldNumericBin5, FldInvalid, 0, 0, 0, 0, nonarray, 0, "RETURN-CODE", - 0, {}, {2,2,4,0, NULL}, NULL }, - { 0, FldNumericBin5, FldInvalid, 0, 0, 0, 0, nonarray, 0, "LINAGE-COUNTER", - 0, {}, {2,2,4,0, NULL}, NULL }, - { 0, FldLiteralA, FldInvalid, 0, 0, 0, 0, nonarray, 0, "_dev_stdin", - 0, {}, {0,0,0,0, "/dev/stdin"}, NULL }, - { 0, FldLiteralA, FldInvalid, constq, 0, 0, 0, nonarray, 0, "_dev_stdout", - 0, {}, {0,0,0,0, "/dev/stdout"}, NULL }, - { 0, FldLiteralA, FldInvalid, constq, 0, 0, 0, nonarray, 0, "_dev_stderr", - 0, {}, {0,0,0,0, "/dev/stderr"}, NULL }, - { 0, FldLiteralA, FldInvalid, constq, 0, 0, 0, nonarray, 0, "_dev_null", - 0, {}, {0,0,0,0, "/dev/null"}, NULL }, - -}; - static symbol_elem_t -elementize( cbl_field_t& field ) { +elementize( const cbl_field_t& field ) { symbol_elem_t sym (SymField); sym.elem.field = field; + // Dubner did the following because he didn't feel like creating yet another + // cbl_field_t constructor that included the hardcoded encoding for the + // global special registers. + sym.elem.field.codeset.set(); return sym; } @@ -454,12 +344,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; } @@ -577,9 +461,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; @@ -630,6 +511,9 @@ symbol_elem_cmp( const void *K, const void *E ) case SymSpecial: return special_pair_cmp(k->elem.special, e->elem.special)? 0 : 1; break; + case SymLocale: + return strcasecmp(k->elem.locale.name, e->elem.locale.name); + break; case SymAlphabet: return strcasecmp(k->elem.alphabet.name, e->elem.alphabet.name); break; @@ -796,9 +680,25 @@ symbol_special( size_t program, const char name[] ) } struct symbol_elem_t * +symbol_locale( size_t program, const char name[] ) +{ + cbl_locale_t locale(name); + assert(strlen(name) < sizeof locale.name); + strcpy(locale.name, name); + + struct symbol_elem_t key(SymLocale, program), *e; + key.elem.locale = locale; + + e = static_cast<struct symbol_elem_t *>(lfind( &key, symbols.elems, + &symbols.nelem, sizeof(key), + symbol_elem_cmp ) ); + return e; +} + +struct symbol_elem_t * symbol_alphabet( size_t program, const char name[] ) { - cbl_alphabet_t alphabet(YYLTYPE(), custom_encoding_e); + cbl_alphabet_t alphabet(YYLTYPE(), custom_encoding_e); // cppcheck-suppress syntaxError assert(strlen(name) < sizeof alphabet.name); strcpy(alphabet.name, name); @@ -865,7 +765,7 @@ cbl_field_attr_str( cbl_field_attr_t attr ) { case function_e: return "function"; case quoted_e: return "quoted"; case filler_e: return "filler"; - case _spare_e: return "temporary"; + case register_e: return "register"; case intermediate_e: return "intermediate"; case embiggened_e: return "embiggened"; case all_alpha_e: return "all_alpha"; @@ -884,7 +784,7 @@ cbl_field_attr_str( cbl_field_attr_t attr ) { case leading_e: return "leading"; case separate_e: return "separate"; case envar_e: return "envar"; - case dnu_1_e: return "dnu_1"; + case encoded_e: return "encoded"; case bool_encoded_e: return "bool"; case hex_encoded_e: return "hex"; case depends_on_e: return "depends_on"; @@ -905,24 +805,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 @@ -978,13 +878,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 ) { @@ -1014,12 +907,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; } @@ -1050,7 +937,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)); @@ -1070,7 +957,7 @@ end_of_group( size_t igroup ) { if( e->program != group->program ) return isym; if( e->type == SymLabel ) return isym; // end of data division if( e->type == SymField ) { - auto f = cbl_field_of(e); + const cbl_field_t * f = cbl_field_of(e); if( f->level == LEVEL77 || f->level == 66 ) return isym; if( f->level == 1 && f->parent != igroup ) { return isym; @@ -1081,7 +968,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(); } @@ -1105,8 +992,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; } @@ -1120,14 +1007,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); @@ -1135,8 +1023,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); @@ -1152,8 +1039,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++ ) { @@ -1161,25 +1048,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 : @@ -1187,7 +1071,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); @@ -1199,31 +1083,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; @@ -1231,7 +1119,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; @@ -1311,7 +1200,7 @@ static struct symbol_elem_t * // If an 01 record exists for the FD/SD, use its capacity as the // default_record capacity. if( p != symbols_end() ) { - auto record = cbl_field_of(p); + const cbl_field_t * record = cbl_field_of(p); assert(record->level == 1); e = calculate_capacity(p); auto record_size = std::max(record->data.memsize, @@ -1343,7 +1232,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; @@ -1373,10 +1263,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. @@ -1402,7 +1288,7 @@ static struct symbol_elem_t * // If group has a parent that is a record area, expand it, too. if( 0 < group->parent ) { - auto redefined = symbol_redefines(group); + redefined = symbol_redefines(group); if( redefined && is_record_area(redefined) ) { if( redefined->data.capacity < group->data.memsize ) { redefined->data.capacity = group->data.memsize; @@ -1432,7 +1318,7 @@ static struct symbol_elem_t * switch( group->level ) { case 1: case 77: - if( dialect_mf() && is_table(group) ) { + if( is_table(group) ) { size_t elem_size = std::max(group->data.memsize, group->data.memsize); group->data.memsize = elem_size * group->occurs.ntimes(); } @@ -1448,23 +1334,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)" ); - } } } @@ -1500,19 +1369,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; } @@ -1524,7 +1392,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)); @@ -1592,11 +1460,11 @@ cbl_field_t::attr_str( const std::vector<cbl_field_attr_t>& attrs ) const const char *sep = ""; char *out = NULL; - for( auto attr : attrs ) { + for( auto attr_l : attrs ) { char *part = out; - if( has_attr(attr) ) { + if( has_attr(attr_l) ) { int erc = asprintf(&out, "%s%s%s", - part? part : "", sep, cbl_field_attr_str(attr)); + part? part : "", sep, cbl_field_attr_str(attr_l)); if( -1 == erc ) return part; free(part); sep = ", "; @@ -1607,7 +1475,7 @@ cbl_field_t::attr_str( const std::vector<cbl_field_attr_t>& attrs ) const char * field_str( const cbl_field_t *field ) { - static char string[3*sizeof(cbl_name_t)]; + static char string[4*sizeof(cbl_name_t)]; char *pend = string; char name[2*sizeof(cbl_name_t)] = ""; @@ -1619,17 +1487,23 @@ 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()); } } + if( field->codeset.valid() ) { + strcat(name, " ("); + strcat(name, field->codeset.name()); + strcat(name, ") "); + } + 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 = @@ -1637,41 +1511,66 @@ field_str( const cbl_field_t *field ) { if( 'r' == parredef && field->level == 0 ) parredef = 'p'; if( field->has_attr(typedef_e) ) parredef = 'T'; - const char *data = field->data.initial? field->data.initial : NULL; - if( data ) { - auto fig = cbl_figconst_of(data); + const char *init = field->data.initial? field->data.initial : NULL; + if( init ) { + auto fig = cbl_figconst_of(init); if( normal_value_e != fig ) { - data = cbl_figconst_str(fig); + init = cbl_figconst_str(fig); } else { - char *s; - auto n = asprintf(&s, "'%s'", data); - gcc_assert(n); - auto eodata = data + field->data.capacity; - 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) && - field->type != FldPointer && p != NULL ) { - s = p; - p += n; - strcat( p, "(0x" ); - p += 3; - for( auto d=data; d < eodata; d++ ) { - p += sprintf(p, "%02x", *d); +#if 0 + // At this point, we might have to convert 'init' back to ASCII + char *false_init = static_cast<char *>(xmalloc(field->init.capacity+1)); + memcpy(false_init, field->init.initial, field->data.capacity); + false_data[field->data.capacity] = '\0'; + size_t charsout; + + cbl_encoding_t enc_from = field->codeset.encoding; + if( field->type == FldNumericDisplay ) + { + // Apparently we need to trace back the meaning of data.literal for + // field::type == FldNumericDisplay + enc_from = DEFAULT_SOURCE_ENCODING; + } + + init = __gg__iconverter(enc_from, + DEFAULT_SOURCE_ENCODING, + false_data, + field->data.capacity, + &charsout); +#endif + auto eoinit = init + strlen(init); + char *s = xasprintf("'%s'", init); + + // No NUL within the initial data. + auto ok = std::none_of( init, eoinit, + []( char ch ) { return ch == '\0'; } ); + assert(ok); + + // If any of the init are unprintable, provide a hex version. + if( ! std::all_of(init, eoinit, fisprint) ) { + if( is_elementary(field->type) && field->type != FldPointer ) { + const size_t len = strlen(s) + 8 + 2 * field->data.capacity; + s = reinterpret_cast<char*>(xrealloc(s, len)); + strcat( s, " (0x" ); + char *p = s + strlen(s); + for( auto d=init; d < eoinit; d++ ) { + p += sprintf(p, "%02x", static_cast<unsigned char>(*d)); } - strcat( p++, ")" ); + strcat( s, ")" ); + assert(strlen(s) < len); } } - data = s; + init = s; } } else { - data = "NULL"; + init = "NULL"; if( field->type == FldSwitch ) { - data = xasprintf("0x%02x", field->data.upsi_mask_of()->value); + init = xasprintf("0x%02x", field->data.upsi_mask_of()->value); } } if( field->level == 88 ) { const auto& dom = *field->data.domain_of(); - data = xasprintf("%s%s %s - %s%s", + init = xasprintf("%s%s %s - %s%s", dom.first.all? "A" : "", value_or_figconst_name(dom.first.name()) , dom.first.is_numeric? "(num)" : "", @@ -1690,20 +1589,20 @@ field_str( const cbl_field_t *field ) { intermediate_e, embiggened_e, all_alpha_e, all_x_e, all_ax_e, prog_ptr_e, scaled_e, refmod_e, based_e, any_length_e, /* global_e, external_e, */ blank_zero_e, /* linkage_e, local_e, */ leading_e, - separate_e, envar_e, dnu_1_e, bool_encoded_e, hex_encoded_e, + separate_e, envar_e, encoded_e, bool_encoded_e, hex_encoded_e, depends_on_e, /* initialized_e, */ has_value_e, ieeedec_e, big_endian_e, same_as_e, record_key_e, typedef_e, strongdef_e, }; 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, field->data.memsize, field->data.capacity, field->data.digits, field->data.rdigits, - data, field->attr_str(attrs), field->line ); + init, field->attr_str(attrs), field->line ); return string; } @@ -1719,7 +1618,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); } @@ -1731,13 +1630,15 @@ struct capacity_of { static void extend_66_capacity( cbl_field_t *alias ) { static_assert(sizeof(symbol_elem_t*) == sizeof(const char *), - "all pointers must be same size"); - assert(alias->data.picture); + "all pointers must be same size"); + assert(alias->level == 66); assert(alias->type == FldGroup); + assert(alias->data.picture); + // If data.picture is not NULL, it is the THRU symbol, see symbol_field_alias2. symbol_elem_t *e = symbol_at(alias->parent); symbol_elem_t *e2 = reinterpret_cast<symbol_elem_t*>(const_cast<char*>(alias->data.picture)); - assert(e < e2); + assert(symbol_index(e) < symbol_index(e2)); alias->data.picture = NULL; capacity_of cap; @@ -1752,6 +1653,9 @@ extend_66_capacity( cbl_field_t *alias ) { bool symbols_alphabet_set( size_t program, const char name[]) { + +//////// +// Older version struct alpha { void operator()( symbol_elem_t& elem ) const { if( elem.type == SymAlphabet ) { @@ -1761,7 +1665,7 @@ symbols_alphabet_set( size_t program, const char name[]) { }; // Define alphabets for codegen. - std::for_each(symbols_begin(), symbols_end(), alpha() ); + std::for_each(symbols_begin(program), symbols_end(), alpha() ); // Set collation sequence before parser_symbol_add. if( name ) { @@ -1772,6 +1676,38 @@ symbols_alphabet_set( size_t program, const char name[]) { parser_alphabet_use(*cbl_alphabet_of(e)); } return true; +// End older version +//////// + +//// // Define alphabets for codegen. +//// const cbl_alphabet_t *alphabet = nullptr; +//// bool supported = true; +//// +//// std::for_each( symbols_begin(program), symbols_end(), +//// [&alphabet, &supported]( const auto& sym ) { +//// if( sym.type == SymAlphabet ) { +//// alphabet = cbl_alphabet_of(&sym); +//// supported = __gg__encoding_iconv_valid(alphabet->encoding); +//// if( supported ) { +//// parser_alphabet( *alphabet ); +//// } +//// } +//// } ); +//// if( ! supported ) { +//// const char *encoding = __gg__encoding_iconv_name(alphabet->encoding); +//// cbl_unimplemented("alphabet %qs (as %qs)", alphabet->name, encoding); +//// return false; +//// } +//// +//// // Set collation sequence before parser_symbol_add.` +//// if( name ) { +//// symbol_elem_t *e = symbol_alphabet(program, name); +//// if( !e ) { +//// return false; +//// } +//// parser_alphabet_use(*cbl_alphabet_of(e)); +//// } +//// return true; } static std::ostream& @@ -1779,6 +1715,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 << ',' @@ -1802,16 +1741,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(); @@ -1832,11 +1762,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. @@ -1858,8 +1783,7 @@ symbols_update( size_t first, bool parsed_ok ) { break; case 1: pend = calculate_capacity(p); - if( dialect_mf() && is_table(field) ) { - cbl_field_t *field = cbl_field_of(p); + if( is_table(field) ) { if( field->data.memsize < field->size() ) { field->data.memsize = field->size(); } @@ -1881,10 +1805,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; @@ -1902,7 +1822,7 @@ symbols_update( size_t first, bool parsed_ok ) { bool size_invalid = field->data.memsize > 0 && symbol_redefines(field); if( size_invalid ) { // redefine of record area is ok - auto redefined = symbol_redefines(field); + const cbl_field_t * redefined = symbol_redefines(field); size_invalid = ! is_record_area(redefined); } if( !field->is_valid() || size_invalid ) @@ -1925,8 +1845,8 @@ symbols_update( size_t first, bool parsed_ok ) { if( e == symbols_end() ) { // no field redefines the file's default record auto file = cbl_file_of(symbol_at(field->parent)); - ERROR_FIELD(field, "line %d: %s lacks a file description", - file->line, file->name); + ERROR_FIELD(field, "%s lacks a file description", + file->name); return 0; } } @@ -1937,28 +1857,25 @@ 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); + gcc_unreachable(); } } 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)); @@ -1973,6 +1890,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); @@ -1980,7 +1906,7 @@ symbols_update( size_t first, bool parsed_ok ) { } // Verify REDEFINing field has no ODO components - auto parent = symbol_redefines(field); + const cbl_field_t * parent = symbol_redefines(field); if( parent && !is_record_area(parent) && is_variable_length(field) ) { ERROR_FIELD(field, "line %d: REDEFINES field %s cannot be variable length", field->line, field->name); @@ -1993,6 +1919,52 @@ symbols_update( size_t first, bool parsed_ok ) { field->line, field->level_str(), field->name); continue; } + if( is_numeric(field) && ! field->has_attr(constant_e) ) { + if( field->data.capacity == 0 ) { + ERROR_FIELD(field, "numeric %qs has USAGE that requires PICTURE %s", + field->name, field->data.initial); + } + } + + if( ! field->codeset.consistent() ) { + if( ! field->codeset.valid() ) { + switch(field->type) { + case FldForward: + case FldInvalid: + gcc_unreachable(); + case FldAlphaEdited: + case FldAlphanumeric: + case FldClass: + case FldDisplay: + case FldGroup: + case FldLiteralA: + case FldLiteralN: + case FldNumericDisplay: + case FldNumericEdited: + if( ! (field->has_attr(register_e) || field->has_attr(hex_encoded_e)) ) { + error_msg(symbol_field_location(field_index(field)), + "internal: %qs encoding not defined", field->name); + } + break; + case FldConditional: + case FldFloat: + case FldIndex: + case FldNumericBin5: + case FldNumericBinary: + case FldPacked: + case FldPointer: + case FldSwitch: + break; + } + } else { + if( ! (field->has_attr(register_e) || field->has_attr(hex_encoded_e)) ) { + error_msg(symbol_field_location(field_index(field)), + "internal: %qs encoding %qs inconsistent", + field->name, + cbl_alphabet_t::encoding_str(field->codeset.encoding) ); + } + } + } assert( ! field->is_typedef() ); @@ -2071,7 +2043,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); @@ -2169,15 +2142,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) ) { @@ -2215,6 +2188,9 @@ symbol_field_parent_set( struct cbl_field_t *field ) return NULL; } prior->type = FldGroup; + if( ! prior->codeset.set() ) { // needs attention + dbgmsg("'%s' is already National", prior->name); + } field->attr |= numeric_group_attrs(prior); } // verify level 88 domain value @@ -2255,7 +2231,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 ) { @@ -2272,8 +2248,10 @@ add_token( symbol_elem_t sym ) { return sym; } +const std::list<cbl_field_t> cdf_literalize(); + /* - * When adding registers, be sure to add a complementary cblc_field_t + * When adding special registers, be sure to create the actual cblc_field_t * in libgcobol/constants.cc. */ void @@ -2292,53 +2270,63 @@ symbol_table_init(void) { // These should match the definitions in libgcobol/constants.cc static cbl_field_t constants[] = { - { 0, FldAlphanumeric, FldInvalid, space_value_e | constq, 0, 0, 0, nonarray, 0, - "SPACE", 0, {}, {1,1,0,0, " \0\xFF"}, NULL }, - { 0, FldAlphanumeric, FldInvalid, space_value_e | constq , 0, 0, 0, nonarray, 0, - "SPACES", 0, {}, {1,1,0,0, " \0\xFF"}, NULL }, - { 0, FldAlphanumeric, FldInvalid, low_value_e | constq, 0, 0, 0, nonarray, 0, - "LOW_VALUES", 0, {}, {1,1,0,0, "L\0\xFF"}, NULL }, - { 0, FldAlphanumeric, FldInvalid, zero_value_e | constq, 0, 0, 0, nonarray, 0, - "ZEROS", 0, {}, {1,1,0,0, "0"}, NULL }, - { 0, FldAlphanumeric, FldInvalid, high_value_e | constq, 0, 0, 0, nonarray, 0, - "HIGH_VALUES", 0, {}, {1,1,0,0, "H\0\xFF"}, NULL }, + { FldAlphanumeric, space_value_e | int(constq) | register_e, + {1,1,0,0, " \0\xFF"}, 0, "SPACE" }, + { FldAlphanumeric, space_value_e | int(constq) | register_e, + {1,1,0,0, " \0\xFF"}, 0, "SPACES" }, + { FldAlphanumeric, low_value_e | int(constq) | register_e, + {1,1,0,0, "L\0\xFF"}, 0, "LOW_VALUES" }, + { FldAlphanumeric, zero_value_e | int(constq) | register_e, + {1,1,0,0, "0"}, 0, "ZEROS" }, + { FldAlphanumeric, high_value_e | int(constq) | register_e, + {1,1,0,0, "H\0\xFF"}, 0, "HIGH_VALUES" }, // IBM standard: QUOTE is a double-quote unless APOST compiler option - { 0, FldAlphanumeric, FldInvalid, quote_value_e | constq , 0, 0, 0, nonarray, 0, - "QUOTES", 0, {}, {1,1,0,0, "\"\0\xFF"}, NULL }, - { 0, FldPointer, FldPointer, constq , 0, 0, 0, nonarray, 0, - "NULLS", 0, {}, {8,8,0,0, zeroes_for_null_pointer}, NULL }, + { FldAlphanumeric, quote_value_e | int(constq) | register_e , + {1,1,0,0, "\"\0\xFF"}, 0, "QUOTES" }, + { FldPointer, int(constq) | register_e , + {8,8,0,0, zeroes_for_null_pointer}, 0, "NULLS" }, // IBM defines TALLY // 01 TALLY GLOBAL PICTURE 9(5) USAGE BINARY VALUE ZERO. - { 0, FldNumericBin5, FldInvalid, signable_e, 0, 0, 0, nonarray, 0, - "_TALLY", 0, {}, {16, 16, MAX_FIXED_POINT_DIGITS, 0, NULL}, NULL }, + { FldNumericBin5, signable_e | register_e, + {16, 16, MAX_FIXED_POINT_DIGITS, 0, NULL}, 0, "_TALLY" }, // 01 ARGI is the current index into the argv array - { 0, FldNumericBin5, FldInvalid, signable_e, 0, 0, 0, nonarray, 0, - "_ARGI", 0, {}, {16, 16, MAX_FIXED_POINT_DIGITS, 0, NULL}, NULL }, + { FldNumericBin5, signable_e | register_e, + {16, 16, MAX_FIXED_POINT_DIGITS, 0, NULL}, 0, "_ARGI" }, // These last two don't require actual storage; they get BOOL var_decl_node // in parser_symbol_add() - { 0, FldConditional, FldInvalid, constant_e , 0, 0, 0, nonarray, 0, - "_VERY_TRUE", 0, {}, {1,1,0,0, ""}, NULL }, - { 0, FldConditional, FldInvalid, constant_e , 0, 0, 0, nonarray, 0, - "_VERY_FALSE", 0, {}, {1,1,0,0, ""}, NULL }, + { FldConditional, constant_e | register_e , {1,1,0,0, ""}, 0, "_VERY_TRUE" }, + { FldConditional, constant_e | register_e , {1,1,0,0, ""}, 0, "_VERY_FALSE" }, }; for( struct cbl_field_t *f = constants; f < constants + COUNT_OF(constants); f++ ) { f->our_index = table.nelem; struct symbol_elem_t sym(SymField, 0); sym.elem.field = *f; + // The following makes these constants match the definitions in + // constants.cc. Consider expanding the constructor fo cbl_field_t to + // handle encoding. + sym.elem.field.codeset.encoding = iconv_CP1252_e; table.elems[table.nelem++] = sym; } static symbol_elem_t environs[] = { + { symbol_elem_t{ 0, cbl_special_name_t{0, CONSOLE_e, "CONSOLE", 0, "/dev/stdout"}} }, // stdout in DISPLAY; stdin in ACCEPT + + { symbol_elem_t{ 0, cbl_special_name_t{0, STDIN_e, "STDIN", 0, "/dev/stdin"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, SYSIN_e, "SYSIN", 0, "/dev/stdin"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, SYSIPT_e, "SYSIPT", 0, "/dev/stdout"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, SYSIPT_e, "SYSIPT", 0, "/dev/stdin"}} }, + + { symbol_elem_t{ 0, cbl_special_name_t{0, STDOUT_e, "STDOUT", 0, "/dev/stdout"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, SYSOUT_e, "SYSOUT", 0, "/dev/stdout"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, SYSLIST_e, "SYSLIST", 0, "/dev/stdout"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, SYSLST_e, "SYSLST", 0, "/dev/stdout"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, SYSPUNCH_e, "SYSPUNCH", 0, "/dev/stderr"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, SYSPCH_e, "SYSPCH", 0, "/dev/stderr"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, CONSOLE_e, "CONSOLE", 0, "/dev/stdout"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, STDERR_e, "STDERR", 0, "/dev/stderr"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, SYSERR_e, "SYSERR", 0, "/dev/stderr"}} }, + { symbol_elem_t{ 0, cbl_special_name_t{0, C01_e, "C01", 0, "/dev/null"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, C02_e, "C02", 0, "/dev/null"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, C03_e, "C03", 0, "/dev/null"}} }, @@ -2358,10 +2346,6 @@ symbol_table_init(void) { { symbol_elem_t{ 0, cbl_special_name_t{0, S04_e, "S04", 0, "/dev/null"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, S05_e, "S05", 0, "/dev/null"}} }, { symbol_elem_t{ 0, cbl_special_name_t{0, AFP_5A_e, "AFP-5A", 0, "/dev/null"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, STDIN_e, "STDIN", 0, "/dev/stdin"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, STDOUT_e, "STDOUT", 0, "/dev/stdout"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, STDERR_e, "STDERR", 0, "/dev/stderr"}} }, - { symbol_elem_t{ 0, cbl_special_name_t{0, SYSERR_e, "SYSERR", 0, "/dev/stderr"}} }, }; struct symbol_elem_t *p = table.elems + table.nelem; @@ -2371,6 +2355,49 @@ symbol_table_init(void) { assert(table.nelem < table.capacity); + /** + * Debug register record + 01 DEBUG-ITEM. + 02 DEBUG-LINE PIC X(6). + 02 FILLER PIC X VALUE SPACE. + 02 DEBUG-NAME PIC X(30). + 02 FILLER PIC X VALUE SPACE. + 02 DEBUG-SUB-1 PIC S9999 SIGN IS LEADING SEPARATE CHARACTER. + 02 FILLER PIC X VALUE SPACE. + 02 DEBUG-SUB-2 PIC S9999 SIGN IS LEADING SEPARATE CHARACTER. + 02 FILLER PIC X VALUE SPACE. + 02 DEBUG-SUB-3 PIC S9999 SIGN IS LEADING SEPARATE CHARACTER. + 02 FILLER PIC X VALUE SPACE. + 02 DEBUG-CONTENTS PIC X(76). + **/ + + static cbl_field_t debug_registers[] = { + { FldGroup, register_e, + {132,132,0,0, NULL}, 1, "DEBUG-ITEM" }, + { FldAlphanumeric, register_e, + {6,6,0,0, " "}, 2, "DEBUG-LINE" }, + { FldAlphanumeric, register_e|filler_e, + {1,1,0,0, " "}, 2, "FILLER" }, + { FldAlphanumeric, register_e, + {30,30,0,0, NULL}, 2, "DEBUG-NAME" }, + { FldAlphanumeric, register_e|filler_e, + {1,1,0,0, " "}, 2, "FILLER" }, + { FldNumericDisplay, signable_e | register_e | leading_e | separate_e, + {5,5,4,0, NULL}, 2, "DEBUG-SUB-1" }, + { FldAlphanumeric, register_e|filler_e, + {1,1,0,0, " "}, 2, "FILLER" }, + { FldNumericDisplay, signable_e | register_e | leading_e | separate_e, + {5,5,4,0, NULL}, 2, "DEBUG-SUB-2" }, + { FldAlphanumeric, register_e|filler_e, + {1,1,0,0, " "}, 2, "FILLER" }, + { FldNumericDisplay, signable_e | register_e | leading_e | separate_e, + {5,5,4,0, NULL}, 2, "DEBUG-SUB-3" }, + { FldAlphanumeric, register_e | filler_e, + {1,1,0,0, " "}, 2, "FILLER" }, + { FldAlphanumeric, signable_e | register_e, + {76,76,0,0, NULL}, 2, "DEBUG-CONTENTS" }, + }; + // debug registers assert(table.nelem + COUNT_OF(debug_registers) < table.capacity); @@ -2388,6 +2415,17 @@ symbol_table_init(void) { std::for_each(debug_start+1, p, parent_elem_set(debug_start - table.elems)); // special registers + static cbl_field_t special_registers[] = { + { FldNumericDisplay, register_e, {2,2,2,0, NULL}, 0, "_FILE_STATUS" }, + { FldNumericBin5, register_e, {2,2,4,0, NULL}, 0, "UPSI-0" }, + { FldNumericBin5, signable_e|register_e, {2,2,4,0, NULL}, 0, "RETURN-CODE" }, + { FldNumericBin5, register_e, {2,2,4,0, NULL}, 0, "LINAGE-COUNTER" }, + { FldLiteralA, register_e, {0,0,0,0, "/dev/stdin"}, 0, "_dev_stdin" }, + { FldLiteralA, int(constq)|register_e, {0,0,0,0, "/dev/stdout"}, 0, "_dev_stdout" }, + { FldLiteralA, int(constq)|register_e, {0,0,0,0, "/dev/stderr"}, 0, "_dev_stderr" }, + { FldLiteralA, int(constq)|register_e, {0,0,0,0, "/dev/null"}, 0, "_dev_null" }, + }; + assert(table.nelem + COUNT_OF(special_registers) < table.capacity); p = table.elems + table.nelem; @@ -2397,6 +2435,34 @@ symbol_table_init(void) { table.nelem = p - table.elems; assert(table.nelem < table.capacity); + // xml registers + static cbl_field_t xml_registers[] = { + { FldNumericBin5, register_e, {4,4,9,0, "0"}, 1, "XML-CODE" }, + { FldAlphanumeric, register_e, {30,30,0,0, " "}, 1, "XML-EVENT" }, + { FldNumericBin5, register_e, {4,4,9,0, "0"}, 1, "XML-INFORMATION" }, + { FldAlphanumeric, register_e | based_e | any_length_e, {1,1,0,0, nullptr}, 1, "XML-NAMESPACE" }, + { FldAlphanumeric, register_e | based_e | any_length_e, {1,1,0,0, nullptr}, 1, "XML-NNAMESPACE" }, + { FldAlphanumeric, register_e | based_e | any_length_e, {1,1,0,0, nullptr}, 1, "XML-NAMESPACE-PREFIX" }, + { FldAlphanumeric, register_e | based_e | any_length_e, {1,1,0,0, nullptr}, 1, "XML-NNAMESPACE-PREFIX" }, + { FldAlphanumeric, register_e | based_e | any_length_e, {1,1,0,0, nullptr}, 1, "XML-TEXT" }, + { FldAlphanumeric, register_e | based_e | any_length_e, {1,1,0,0, nullptr}, 1, "XML-NTEXT" }, + }, * const eoxml = xml_registers + COUNT_OF(xml_registers); + + assert(table.nelem + COUNT_OF(xml_registers) < table.capacity); + + p = table.elems + table.nelem; + p = std::transform(xml_registers, eoxml, p, elementize); + table.nelem = p - table.elems; + assert(table.nelem < table.capacity); + + // Add any CDF values already defined as literals. + // After symbols are ready, the CDF adds them directly. + const std::list<cbl_field_t> cdf_values = cdf_literalize(); + table.nelem += cdf_values.size(); + assert(table.nelem < table.capacity); + + p = std::transform(cdf_values.begin(), cdf_values.end(), p, elementize); + // Initialize symbol table. symbols = table; @@ -2414,8 +2480,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); } /* @@ -2499,7 +2563,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); @@ -2512,16 +2576,23 @@ 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_locale_add( size_t program, const cbl_locale_t *locale ) { + symbol_elem_t sym{ SymLocale, program }; + sym.elem.locale = *locale; + return symbol_add(&sym); +} + +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 ) { @@ -2557,7 +2628,7 @@ symbol_typedef_add( size_t program, struct cbl_field_t *field ) { auto e = symbols_end() - 1; assert( symbols_begin() < e ); if( e->type == SymField ) { - auto f = cbl_field_of(e); + const cbl_field_t * f = cbl_field_of(e); if( f == field ) return e; } @@ -2595,7 +2666,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. @@ -2603,35 +2674,19 @@ symbol_field_add( size_t program, struct cbl_field_t *field ) field->attr = inherit & parent->attr; field->attr |= numeric_group_attrs(parent); field->usage = parent->usage; + if( field->level == 66 || field->level == 88 ) { + field->codeset = parent->codeset; + } // BINARY-LONG, for example, sets capacity. if( is_numeric(parent->usage) && parent->data.capacity > 0 ) { field->type = parent->usage; field->data = parent->data; - field->data = 0.0; + field->data = 0; // cppcheck-suppress redundantAssignment + // // cppcheck doesn't understand multiple overloaded operator= field->data.initial = NULL; } } - 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 ) { @@ -2746,6 +2801,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[] ) { @@ -2761,6 +2817,7 @@ symbol_register( const char name[] ) return p; } +// cppcheck-suppress-end [CastIntegerToAddressAtReturn] // Find current 01 record during Level 66 construction. const symbol_elem_t * @@ -2788,11 +2845,8 @@ symbol_field_forward_add( size_t program, size_t parent, auto e = symbol_field(program, parent, name); if( e ) return e; - struct cbl_field_t field = { 0, - FldForward, FldInvalid, 0, parent, 0, 0, - nonarray, line, "", - 0, cbl_field_t::linkage_t(), - {0,0,0,0, " "}, NULL }; + cbl_field_t field = { FldForward, 0, line }; + field.parent = parent; if( sizeof(field.name) < strlen(name) ) { dbgmsg("%s:%d: logic error: name %s too long", __func__, __LINE__, name); return NULL; @@ -2823,11 +2877,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), @@ -2836,6 +2891,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); @@ -2943,7 +2999,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; } @@ -2976,6 +3032,7 @@ symbol_field_same_as( cbl_field_t *tgt, const cbl_field_t *src ) { cbl_field_t dup = {}; dup.parent = field_index(tgt); dup.line = tgt->line; + dup.codeset = tgt->codeset; elem_group_t group(++bog, eog); @@ -3029,7 +3086,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 ); @@ -3067,14 +3124,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; } @@ -3085,8 +3142,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, @@ -3143,12 +3198,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); @@ -3195,15 +3244,141 @@ constant_of( size_t isym ) return field; } +cbl_locale_t::cbl_locale_t( const cbl_name_t name, const char iconv_name[] ) { + gcc_assert(strlen(name) < sizeof this->name); + strcpy(this->name, name); + + if( iconv_name ) { + encoding = __gg__encoding_iconv_type(iconv_name); + + strcpy(collation, "C"); + // If the iconv_name is prefixed by langauge_COUNTRY (e.g. en_US), capture that. + auto pend = iconv_name + strlen(iconv_name); + auto p = std::find(iconv_name, pend, '.'); + if( p < pend ) { + auto pend2 = std::copy(iconv_name, p, collation); + std::fill(pend2, collation + sizeof(collation), '\0'); + iconv_name = ++p; + } + encoding = __gg__encoding_iconv_type(iconv_name); + } +} + +cbl_alphabet_t::cbl_alphabet_t(const YYLTYPE& loc, size_t locale, cbl_name_t name ) + : loc(loc) + , locale(locale) + , low_index(0) + , high_index(255) + , last_index(0) +{ + if( locale > 0 ) { + encoding = cbl_locale_of(symbol_at(locale))->encoding; + } + memset(collation_sequence, 0xFF, sizeof(collation_sequence)); + if( name ) { // from Special-Names collation_sequence + assert(strlen(name) < sizeof(cbl_name_t)); + strcpy(this->name, name); + } +} + +/* + * As parsed, the alphabet reflects the encoding of the source code. If the + * program uses a different encoding for alphanumeric, convert the alphabet to + * that. + * + * Because a custom alphabet is rare and occurs at most only once per program, + * we don't attempt to avoid re-encoding. "Conversion" of ASCII to ASCII is at + * most 256 calls to iconv(3). + */ +void +cbl_alphabet_t::reencode() { + + const unsigned char * const pend = collation_sequence + sizeof(collation_sequence); + std::vector<char> tgt(256, (char)0xFF); + + /* Keep copies of low_index and last_index for use in run-time as LOW-VALUE + and HIGH-VALUE, which are kept as globals in the source-code codeset + and converted to the display encoding as necessary. */ + + low_char = low_index; + high_char = last_index; + + /* + * For now, assume CP1252 source-code encoding because we're not capturing it + * anywhere except in cbl_field_t::internalize(). The only known examples of + * a custom alphabet are from NIST, which of course are ASCII. + */ + const char *fromcode = __gg__encoding_iconv_name(CP1252_e); + const char *tocode = + __gg__encoding_iconv_name(current_encoding(display_encoding_e)); + iconv_t cd = iconv_open(tocode, fromcode); + +#if optimal_reencode + if( fromcode == tocode ) { // semantically + tgt.resize(0); + return tgt; // Return empty vector; caller copies zero bytes. + } +#endif + + /* + * Each position in the alphabet array represents a letter in the source-code + * encoding. The value at that position represents the letter's collation + * position, its sort order. For each letter in alphabet, determine value of + * that letter in the alphanumeric encoding, and set its collation position + * in that alphabet. + */ + for( const unsigned char *p = collation_sequence; p < pend; p++ ) { + if( *p == 0xFF ) continue; + unsigned char ch = p - collation_sequence; + unsigned char pos[8] = {}; + size_t inbytesleft = 1, outbytesleft = sizeof(pos); + char *inbuf = reinterpret_cast<char*>(&ch), + *outbuf = reinterpret_cast<char*>(pos); + + size_t n = iconv(cd, &inbuf, &inbytesleft, &outbuf, &outbytesleft); + + if( n == size_t(-1) ) { + error_msg(loc, "%s character '%c' (%x hex) cannot be converted to %s", + fromcode, ch, ch, tocode); + continue; + } + if( n != 0 ) { + dbgmsg("%s character '%c' (%x hex) irreversibly converted to %s", + fromcode, ch, ch, tocode); + } + assert(outbytesleft < sizeof(pos)); + n = sizeof(pos) - outbytesleft; + if( 1 < n ) { + error_msg(loc, "%s character '%c' (%x hex) requires %zu bytes as %s", + fromcode, ch, ch, n, tocode); + continue; + } + + if( ch == low_index ) { + low_index = pos[0]; + } + if( ch == last_index ) { + last_index = pos[0]; + } + if( ch == high_index ) { + high_index = pos[0]; + } + + tgt.at(pos[0]) = *p; + } + + std::copy(tgt.begin(), tgt.end(), collation_sequence); +} + bool cbl_alphabet_t::assign( const YYLTYPE& loc, unsigned char ch, unsigned char high_value ) { - if( alphabet[ch] == 0xFF || alphabet[ch] == high_value) { - alphabet[ch] = high_value; + if( collation_sequence[ch] == 0xFF || collation_sequence[ch] == high_value) { + collation_sequence[ch] = high_value; last_index = ch; return true; } - auto taken = alphabet[ch]; - error_msg(loc, "ALPHABET %s, character '%c' (X'%x') " + auto taken = collation_sequence[ch]; + error_msg(loc, "ALPHABET %s, character %<%c%> (X%'%x%') " "in position %d already defined at position %d", name, ISPRINT(ch)? ch : '?', ch, @@ -3215,7 +3390,7 @@ cbl_alphabet_t::assign( const YYLTYPE& loc, unsigned char ch, unsigned char high void cbl_alphabet_t::also( const YYLTYPE& loc, size_t ch ) { if( ch < 256 ) { - alphabet[ch] = alphabet[last_index]; + collation_sequence[ch] = collation_sequence[last_index]; if( ch == high_index ) high_index--; return; } // else it's a figurative constant ... @@ -3228,20 +3403,20 @@ cbl_alphabet_t::also( const YYLTYPE& loc, size_t ch ) { // last_index is already set; use it as the "last value before ALSO" if( attr & low_value_e ) { - alphabet[0] = alphabet[last_index]; + collation_sequence[0] = collation_sequence[last_index]; return; } if( attr & high_value_e ) { - alphabet[high_index--] = alphabet[last_index]; + collation_sequence[high_index--] = collation_sequence[last_index]; return; } if( attr & (space_value_e|quote_value_e) ) { ch = field->data.initial[0]; - alphabet[ch] = alphabet[last_index]; + collation_sequence[ch] = collation_sequence[last_index]; return; } if( attr & (zero_value_e) ) { - alphabet[0] = alphabet[last_index]; + collation_sequence[0] = collation_sequence[last_index]; error_msg(loc, "ALSO value '%s' is unknown", field->name); return; } @@ -3252,15 +3427,25 @@ using std::deque; static deque<cbl_field_t*> stack; static cbl_field_t * -new_temporary_impl( enum cbl_field_type_t type ) +new_temporary_impl( enum cbl_field_type_t type, const cbl_name_t name = nullptr ) { extern int yylineno; - static int nstack, nliteral; static const struct cbl_field_t empty_alpha = { - 0, FldAlphanumeric, FldInvalid, - intermediate_e, 0, 0, 0, nonarray, 0, "", - 0, cbl_field_t::linkage_t(), - {}, NULL }; + FldAlphanumeric, intermediate_e, + {MAXIMUM_ALPHA_LENGTH, + MAXIMUM_ALPHA_LENGTH, 0, 0, NULL} }; + static const struct cbl_field_t empty_float = { + FldFloat, intermediate_e, + {16, 16, 32, 0, NULL} }; + static const struct cbl_field_t empty_comp5 = { + FldNumericBin5, + signable_e | intermediate_e, + {16, 16, MAX_FIXED_POINT_DIGITS, 0, NULL} }; + static const struct cbl_field_t empty_conditional = { + FldConditional, intermediate_e, cbl_field_data_t{} }; + static struct cbl_field_t empty_literal = { + FldInvalid, CONSTANT_E, cbl_field_data_t{} }; + struct cbl_field_t *f = new cbl_field_t; f->type = type; @@ -3276,7 +3461,6 @@ new_temporary_impl( enum cbl_field_type_t type ) case FldSwitch: case FldDisplay: case FldPointer: - case FldBlob: break; case FldConditional: *f = empty_conditional; @@ -3301,15 +3485,17 @@ new_temporary_impl( enum cbl_field_type_t type ) f->line = yylineno; if( is_literal(type) ) { + static int nliteral = 0; snprintf(f->name, sizeof(f->name), "_literal%d",++nliteral); } else { + static int nstack = 0; snprintf(f->name, sizeof(f->name), "_stack%d",++nstack); - - 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 + + f->codeset.set(); + return f; } @@ -3322,13 +3508,17 @@ new_temporary_decl() { static inline cbl_field_t * parser_symbol_add2( cbl_field_t *field ) { + if( ! field->codeset.valid() ) { + dbgmsg( "%s:%d: %s (%s) has no encoding", __func__, __LINE__, + field->name, cbl_field_type_str(field->type) ); + } parser_symbol_add(field); return 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"; +new_literal_add( const char initial[], uint32_t len, + cbl_field_attr_t attr, cbl_encoding_t encoding ) { cbl_field_t *field = NULL; if( !(attr & quoted_e) ) { @@ -3340,21 +3530,39 @@ new_literal_add( const char initial[], uint32_t len, enum cbl_field_attr_t attr { field = new_temporary_impl(FldLiteralA); field->attr |= attr; - field->data.initial = len > 0? initial : empty; - field->data.capacity = len; - if( ! field->internalize() ) + if(len == 0) + { + // This will cover UTF-32, should that arise. + size_t nbytes = 4; + char *init = static_cast<char *>(xmalloc(nbytes)); + memset(init, 0, nbytes); + field->data.initial = init; + } + if(len) { - ERROR_FIELD(field, "inconsistent string literal encoding for '%s'", initial); + char *init = static_cast<char *>(xmalloc(len+4)); + memcpy(init, initial, len); + memset(init+len, 0, 4); + field->data.initial = init; } + field->data.capacity = len; } + if( ! field->has_attr(hex_encoded_e) ) { + // If the literal bore a prefix, set the encoding, + if( encoding != cbl_field_t::codeset_t::source_encoding->type ) { + field->codeset.set(encoding); + } + field->internalize(); + } + 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); } @@ -3362,35 +3570,40 @@ new_literal_add( const char initial[], uint32_t len, enum cbl_field_attr_t attr static temporaries_t temporaries; cbl_field_t * -temporaries_t::literal( const char value[], uint32_t len, cbl_field_attr_t attr ) { - auto key = literal_an(value, quoted_e == (attr & quoted_e)); +temporaries_t::literal( uint32_t len, const char value[], + cbl_field_attr_t attr, cbl_encoding_t encoding ) { + bool is_quoted2 = quoted_e == (attr & quoted_e); + bool is_verbatim = hex_encoded_e == (attr & hex_encoded_e); + auto key = literal_an(value, is_quoted2, is_verbatim); - if( 0 == (attr & hex_encoded_e) ) { + if( ! is_verbatim ) { // TODO: try without this test once National is ready auto p = literals.find(key); if( p != literals.end() ) { cbl_field_t *field = p->second; return field; } } - return literals[key] = new_literal_add(value, len, attr); + return literals[key] = new_literal_add(value, len, attr, encoding); } cbl_field_t * -new_literal( uint32_t len, const char initial[], enum cbl_field_attr_t attr ) { - return temporaries.literal(initial, len, attr); +new_literal( uint32_t len, const char initial[], + cbl_field_attr_t attr, cbl_encoding_t encoding ) { + return temporaries.literal(len, initial, attr, encoding); } 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 +3613,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 +3644,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 +3656,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,27 +3681,51 @@ 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); } +extern os_locale_t os_locale; + +const encodings_t cbl_field_t::codeset_t::source_encodings[2] = { + { false, iconv_UTF_8_e, "UTF-8" }, + { true, iconv_CP1252_e, "CP1252" }, +}; +const encodings_t * cbl_field_t::codeset_t::source_encoding = { + cbl_field_t::codeset_t::source_encodings +}; + +const encodings_t cbl_field_t::codeset_t::standard_internal = { + true, iconv_CP1252_e, "CP1252" +}; +#define standard_internal cbl_field_t::codeset_t::standard_internal + cbl_field_t * -new_temporary( enum cbl_field_type_t type, const char *initial ) { - if( ! initial ) { +new_temporary( enum cbl_field_type_t type, const char *initial, bool is_signed ) { + const bool force_unsigned = type == FldNumericBin5 && ! is_signed; + + if( ! initial && ! force_unsigned ) { 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); + auto field = temporaries.literal(strlen(initial), initial, + type == FldLiteralA? quoted_e : none_e, + standard_internal.type); return field; } - cbl_field_t *field = new_temporary_impl(type); - field->data.capacity = strlen(field->data.initial = initial); - temporaries.add(field); + cbl_field_t *field = new_temporary_impl(type, initial); + + // don't reuse unsigned numeric + if( force_unsigned ) { + field->clear_attr(signable_e); + } else { + temporaries.add(field); + } + parser_symbol_add(field); return field; @@ -3536,12 +3764,38 @@ new_temporary_clone( const cbl_field_t *orig) { temporaries.add(field); } field->data = orig->data; - if( field->type == FldNumericBin5 ) field->type = orig->type; + if( field->type == FldNumericBin5 ) { + field->type = orig->type; + field->codeset = orig->codeset; + } field->attr = intermediate_e; return parser_symbol_add2(field); } +/* + * This set of ASCII-like encodings is incomplete and possibly wrong. A + * complete definition would better supported with a Boolean in enccodings_t. + * If it returns false pessimistically, the only consequence is inefficiency: + * the string is processed by iconv(3). + */ +bool +cbl_field_t::holds_ascii() const { + // True if the encoding is a superset of ASCII. + switch(codeset.encoding) { + case ASCII_e: + case CP1252_e: + case iso646_e: + return true; + default: + if( iconv_1026_e <= codeset.encoding && + codeset.encoding <= iconv_ANSI_X3_4_e ) { + return true; + } + } + return false; +} + bool cbl_field_t::is_ascii() const { return std::all_of( data.initial, @@ -3567,124 +3821,172 @@ cbl_field_t::is_ascii() const { * compilation, if it moves off the default, it adjusts only once, and * never reverts. */ -static const char standard_internal[] = "CP1252//"; -extern os_locale_t os_locale; - -static const char * -guess_encoding() { - static const char *fromcode; - - if( ! fromcode ) { - return fromcode = os_locale.assumed; - } - - if( fromcode == os_locale.assumed ) { - fromcode = os_locale.codeset; - if( 0 != strcmp(fromcode, "C") ) { // anything but that - return fromcode; - } - } - - return standard_internal; -} const char * cbl_field_t::internalize() { - static const char *tocode = standard_internal; - static const char *fromcode = guess_encoding(); - static iconv_t cd = iconv_open(tocode, fromcode); + /* The purpose of this routine is to return a nul-terminated string which + is data.initial converted from the source-code characters to the + codeset.encoding characters. + + The contract between this routine and the routines that call it is that + for alphanumeric types, data.initial shall have the same number of + characters as will be needed to fill data.capacity. + + Be aware that for PIC X(32) Z"foo", there are the characters "foo", + followed by a NUL, and then 28 spaces to fill it out. It turns out that + iconv, given a character count of 32, converts all 32, including the + embedded NUL. So, that case works even through strlen(initial) is + smaller than the length of initial, which is the same as capacity. + */ + + static const char *fromcode = codeset.source_encodings[0].name; static const size_t noconv = size_t(-1); + static std::unordered_map<std::string, iconv_t> tocodes; - // Sat Mar 16 11:45:08 2024: require temporary environment for testing - if( getenv( "INTERNALIZE_NO") ) return data.initial; + if( ! codeset.valid() ) { + dbgmsg("%s:%d: not converting %s", __func__, __LINE__, data.initial); + return data.initial; + } - bool using_assumed = fromcode == os_locale.assumed; + const char *tocode = __gg__encoding_iconv_name(codeset.encoding); + + std::string toname(tocode); + auto p = tocodes.find(toname); + if( p == tocodes.end() ) { + tocodes[toname] = iconv_open(tocode, fromcode); + } + iconv_t cd = tocodes[toname]; + + if (cd == (iconv_t)-1) { + cbl_message(ParIconvE, + "failed %<iconv_open%> tocode = %qs fromcode = %qs", + tocode, fromcode); + } if( fromcode == tocode || has_attr(hex_encoded_e) ) { return data.initial; } - if( is_ascii() ) return data.initial; + if( data.capacity == 0 ) { + assert(0 == strlen(data.initial)); + return data.initial; + } + if( holds_ascii() && is_ascii() ) { + if( type != FldNumericEdited ) { + if( ! data.initial_within_capacity() ) { + ERROR_FIELD(this, "%s %s VALUE %qs of %zu exceeds size %u", + cbl_field_t::level_str(level), name, data.initial, + strlen(data.initial), data.capacity ); + } + } + return data.initial; + } assert(data.capacity > 0); - std::vector<char> output(data.capacity + 2, '\0'); - char *out = output.data(); - char *in = const_cast<char*>(data.initial); - size_t n, inbytesleft = data.capacity, outbytesleft = output.size(); + // The final 2 bytes of the output are "!\0". It's a debugging sentinel. + size_t n; + size_t inbytesleft = data.capacity; + size_t outbytesleft = inbytesleft; if( !is_literal(this) && inbytesleft < strlen(data.initial) ) { inbytesleft = strlen(data.initial); } + if( type == FldNumericEdited ) { + outbytesleft = inbytesleft; + } + const unsigned int in_len = inbytesleft; + + char *in = const_cast<char*>(data.initial); + char *out = static_cast<char*>( xcalloc(1, outbytesleft + 2) ), *output = out; assert(fromcode != tocode); - while( (n = iconv( cd, &in, &inbytesleft, &out, &outbytesleft)) == noconv ) { - if( !using_assumed ) break; // change only once - fromcode = guess_encoding(); - cd = iconv_open(tocode, fromcode); - dbgmsg("%s: trying input encoding %s", __func__, fromcode); - if( fromcode == tocode ) break; - } + /* + * If we're currently assuming the source code is encoded according to the + * locale (the default), and there's an iconv failure, try once more using a + * different assumption, that the source code is encoded as CP1252. + * + * This heuristic means that some UTF-8 literals could be converted until a + * CP1252 byte is encountered. We could be stricter about that. + * + * Also possible is a failure to avoid iconv with fromcode and tocode denote + * the same encoding but with different spellings, e.g. CP1252 and CP1252//. + */ - if( n == noconv ) { - if( !using_assumed ) { - yywarn("failed to decode '%s' as %s", data.initial, fromcode); - return NULL; + do { + if( (n = iconv( cd, &in, &inbytesleft, &out, &outbytesleft)) == noconv ) { + if( fromcode == codeset.source_encodings[0].name ) { + codeset.source_encoding = &codeset.source_encodings[1]; + fromcode = codeset.source_encoding->name; + tocodes.clear(); + cd = tocodes[toname] = iconv_open(tocode, fromcode); + dbgmsg("%s: trying input encoding %s", __func__, fromcode); + if( fromcode == tocode ) return data.initial; // no conversion required. + n = noconv - 1; // try again + } } + if( n == 0 ) break; + } while( n != noconv ); + + if( n == noconv ) { + size_t i = in_len - inbytesleft; + yyerror("failed to encode %s %qs as %s (%zu of %u bytes left)", + fromcode, data.initial + i, tocode, inbytesleft, in_len); + if( false ) return NULL; return data.initial; } if( 0 < inbytesleft ) { // data.capacity + inbytesleft is not correct if the remaining portion has - // multibyte characters. But the fact reamins that the VALUE is too big. + // multibyte characters. But the fact remains that the VALUE is too big. ERROR_FIELD(this, "%s %s VALUE '%s' requires %zu bytes for size %u", cbl_field_t::level_str(level), name, data.initial, data.capacity + inbytesleft, data.capacity ); } // Replace data.initial only if iconv output differs. - 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); - } + if( 0 != memcmp(data.initial, output, out - output) ) { + assert(out <= output + data.capacity || type == FldNumericEdited); dbgmsg("%s: converted '%.*s' to %s", __func__, data.capacity, data.initial, tocode); - - int len = int(out - output.data()); - char *mem = static_cast<char*>( xcalloc(1, output.size()) ); - - // Set the new memory to all blanks, tacking a '!' on the end. - memset(mem, 0x20, output.size() - 1); - mem[ output.size() - 2] = '!'; + struct localspace_t { + char space[4]; + size_t len, erc; + explicit localspace_t( iconv_t cd ) { + static char input[1] = { 0x20 }; + size_t inbytesleft2 = sizeof(input), outbytesleft2 = sizeof(space); + char *in2 = input, *out2 = space; + + erc = iconv(cd, &in2, &inbytesleft2, &out2, &outbytesleft2); + len = out2 - space; + } + bool valid() const { return 0 < len && erc != size_t(-1); } + } spc(cd); + + if( ! spc.valid() ) { + dbgmsg("%s:%d: iconv failed for %s: %s", __func__, __LINE__, + tocode, xstrerror(errno)); + ERROR_FIELD(this, "iconv failed: %s", xstrerror(errno)); + return data.initial; + } + assert( 0 < spc.len && spc.valid() ); if( is_literal(this) ) { - data.capacity = len; // trailing '!' will be overwritten + data.capacity = out - output; // trailing '!' will be overwritten } - - memcpy(mem, output.data(), len); // copy only as much as iconv converted - - 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); + // Pad with trailing blanks, tacking a '!' on the end. + for( const char *eout = output + data.capacity; + out < eout; + out += spc.len ) { + memcpy(out, spc.space, spc.len); } - + // Numeric literal strings may have leading zeros, making their length + // longer than their capacity. + out[0] = type == FldLiteralN? '\0' : '!'; + assert(out[1] == '\0'); + data.orig = data.initial; + data.initial = output; + } else { + free(output); } return data.initial; @@ -3703,8 +4005,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); } @@ -3734,12 +4036,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()); } /* @@ -3804,44 +4103,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); } @@ -3854,59 +4131,45 @@ 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); + /* cppcheck warns that the following statement depends on the order of + evaluation of side effects. Since this isn't my code, and since I don't + think the warning can be eliminated without rewriting it, I am just + supprressing it. + -- Bob Dubner, 2025-07-14 */ + // cppcheck-suppress unknownEvaluationOrder + bool has_section = std::any_of( ++eval, symbols_end(), + [program = eval->program]( const auto& sym ) { + if( program == sym.program && sym.type == SymLabel ) { + const auto& L(sym.elem.label); + // true if the symbol is an explicit label. + return L.type == LblSection && L.name[0] != '_'; } return false; } ); if( yydebug && ! has_section ) { - symbols_dump(program, true); + symbols_dump(eval_label_index, true); } - // Return true if no Declaratives, because the (non-)requirement is met. - // Return false if Declaratives exist, because no Section name was found. + // Return true if a user-defined SECTION was found after the Declaratives + // label section. return has_section; } @@ -3919,7 +4182,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(), @@ -3961,11 +4225,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); @@ -3976,11 +4235,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); @@ -4057,7 +4311,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; @@ -4086,7 +4340,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--) @@ -4099,7 +4353,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; } @@ -4108,7 +4362,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'; @@ -4131,7 +4385,6 @@ expand_picture(const char *picture) { pcurrency[i] = 'B'; } - dest_length += sign_length; } } @@ -4362,7 +4615,7 @@ symbol_program_callables( size_t program ) { if( e->type != SymLabel ) continue; if( e->elem.label.type != LblProgram ) continue; - auto prog = cbl_label_of(e); + const cbl_label_t * prog = cbl_label_of(e); if( program == symbol_index(e) && !prog->recursive ) continue; if( (self->parent == prog->parent && prog->common) || @@ -4396,6 +4649,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 @@ -4407,6 +4661,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 ) { @@ -4414,6 +4669,11 @@ symbol_currency( char sign ) { if( currencies.size() == 0 ) { currencies['$'] = "$"; } + if( sign == '\0' ) { // default + auto result = currencies.begin(); + gcc_assert(result != currencies.end()); + return result->second; + } auto result = currencies.find(sign); return result == currencies.end()? NULL : result->second; } @@ -4429,24 +4689,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 @@ -4459,7 +4714,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); @@ -4477,14 +4732,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); } @@ -4511,15 +4766,40 @@ cbl_occurs_t::subscript_ok( const cbl_field_t *subscript ) const { // It must be a number. if( subscript->type != FldLiteralN ) return false; - auto sub = subscript->data.value_of(); + // This only gets us int64_t, which is more than adequate for a table subscript + auto sub = real_to_integer (TREE_REAL_CST_PTR (subscript->data.value_of())); + REAL_VALUE_TYPE csub; + real_from_integer (&csub, VOIDmode, sub, SIGNED); - if( sub < 1 || sub != size_t(sub) ) { + if( sub < 1 + || !real_identical (&csub, + TREE_REAL_CST_PTR (subscript->data.value_of())) ) { return false; // zero/fraction invalid } if( bounds.fixed_size() ) { - return sub <= bounds.upper; + return (size_t)sub <= bounds.upper; } - return bounds.lower <= sub && sub <= bounds.upper; + return bounds.lower <= (size_t)sub && (size_t)sub <= bounds.upper; +} + +const cbl_field_t * +symbol_unresolved_file_key( const cbl_file_t * file, + const cbl_name_t key_field_name ) { + const symbol_elem_t *file_sym = symbol_elem_of(file); + size_t program = file_sym->program; + for( const symbol_elem_t *e = file_sym - 1; e->program == program; e-- ) { + if( e->type == SymFile ) break; + if( e->type == SymField ) { + auto f = cbl_field_of(e); + if( f->type == FldLiteralA ) break; + if( f->type == FldForward ) { + if( 0 == strcmp(key_field_name, f->name) ) { + return f; + } + } + } + } + return nullptr; } cbl_file_key_t:: @@ -4605,8 +4885,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); @@ -4629,8 +4909,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; } @@ -4646,13 +4927,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); } @@ -4661,7 +4943,7 @@ cbl_file_key_t::deforward( size_t ifile ) { if( ifield == fwd ) { ERROR_FIELD(field, "line %d: %s of %s " "is not defined", - file->line, field->name, file->name); + field->line, field->name, file->name); return ifield; } @@ -4690,9 +4972,13 @@ cbl_file_key_t::deforward( size_t ifile ) { // looked-up field must have same file as parent if( ! (parent != NULL && symbol_index(symbol_elem_of(parent)) == ifile) ) { - ERROR_FIELD(field, "line %d: %s of %s " - "is not defined in file description", - file->line, field->name, file->name); + const cbl_field_t *undefined = + symbol_unresolved_file_key(file, field->name); + int lineno = undefined? undefined->line : file->line; + ERROR_FIELD(undefined? undefined : field, + "line %d: %s of %s " + "is not defined in file description", + lineno, field->name, file->name); } return ifield; } ); @@ -4706,7 +4992,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 = ", "; } @@ -4719,6 +5005,8 @@ cbl_file_key_t::str() const { */ void cbl_file_t::deforward() { + const size_t ifile( symbol_index(symbol_elem_of(this)) ); + if( user_status ) { user_status = symbol_forward_to(user_status); @@ -4730,33 +5018,18 @@ cbl_file_t::deforward() { } for( auto p = keys; p < keys + nkey; p++ ) { - p->deforward( symbol_index(symbol_elem_of(this)) ); + p->deforward(ifile); } } 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()); } /* @@ -4818,11 +5091,13 @@ cbl_file_status_cmp( const void *K, const void *E ) { static long file_status_status_of( file_status_t status ) { size_t n = COUNT_OF(file_status_fields); - file_status_field_t *fs, key { status }; - - fs = (file_status_field_t*)lfind( &key, file_status_fields, - &n, sizeof(*fs), cbl_file_status_cmp ); + const file_status_field_t *fs, key { status }; + fs = static_cast<file_status_field_t*>(lfind( &key, + file_status_fields, + &n, + sizeof(*fs), + cbl_file_status_cmp )); return fs? (long)fs->status : -1; } @@ -4848,21 +5123,6 @@ ast_file_status_between( file_status_t lower, file_status_t upper ) { } bool -is_register_field(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: - return - ( field->parent == 0 - && field->level == 0 - && !(field->attr & intermediate_e) - && !(field->attr & filler_e) - && field->type != FldClass - && field->type != FldBlob - ); - } - -bool has_value( cbl_field_type_t type ) { // Indicates that the field type contains data that can be expressed as // a numeric value @@ -4878,7 +5138,6 @@ has_value( cbl_field_type_t type ) { case FldForward: case FldSwitch: case FldDisplay: - case FldBlob: return false; case FldIndex: case FldPointer: diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h index c189412..e0a7195 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> @@ -48,50 +48,61 @@ #define PICTURE_MAX 64 -// Define a tree type as void pointer outside the generator code. -#ifndef HOWEVER_GCC_DEFINES_TREE -typedef void *tree; -#endif - -#if ! (__HAVE_FLOAT128 && __GLIBC_USE (IEC_60559_TYPES_EXT)) -static_assert( sizeof(output) == sizeof(long double), "long doubles?" ); - -static inline _Float128 -strtof128 (const char *__restrict __nptr, char **__restrict __endptr) { - return strtold(nptr, endptr); -} - -static inline int -strfromf128 (char *restrict string, size_t size, - const char *restrict format, _Float128 value) { - return strfroml(str, n, format, fp); -} -#endif - extern const char *numed_message; enum cbl_dialect_t { - dialect_gcc_e = 0x00, - dialect_ibm_e = 0x01, - dialect_mf_e = 0x02, - dialect_gnu_e = 0x04, + dialect_iso_e = 0x00, + dialect_gcc_e = 0x01, + dialect_ibm_e = 0x02, + dialect_mf_e = 0x04, + dialect_gnu_e = 0x08, }; -extern cbl_dialect_t cbl_dialect; +static inline const char * +cbl_dialect_str(cbl_dialect_t dialect) { + switch(dialect) { + case dialect_iso_e: return "iso"; + case dialect_gcc_e: return "gcc"; + case dialect_ibm_e: return "ibm"; + case dialect_mf_e: return "mf"; + case dialect_gnu_e: return "gnu"; + } + + switch(size_t(dialect)) { + case dialect_mf_e | dialect_gnu_e: return "mf or gnu"; + case dialect_ibm_e | dialect_mf_e | dialect_gnu_e: return "ibm or mf or gnu"; + } + + return "???"; +}; + +// 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 ); } +static inline bool dialect_has( cbl_dialect_t dialect) { + return 0 < (cbl_dialects & dialect); +} + +#ifdef GCC_DIAGNOSTIC_H +bool cbl_diagnostic_kind( cbl_diag_id_t id, diagnostics::kind kind ); +bool cbl_dialect_kind( cbl_dialect_t dialect, diagnostics::kind kind ); +#endif + enum cbl_gcobol_feature_t { feature_gcc_e = 0x00, feature_internal_ebcdic_e = 0x01, @@ -135,7 +146,6 @@ is_numeric( cbl_field_type_t type ) { case FldSwitch: case FldDisplay: case FldPointer: // not numeric because not computable, only settable - case FldBlob: return false; // These types are computable or, in the case of FldIndex, may be // arbitrarily set and incremented. @@ -148,24 +158,20 @@ 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 ); cbl_field_attr_t literal_attr( const char prefix[] ); -static inline bool -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 ); @@ -189,7 +195,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; } @@ -235,21 +241,27 @@ bool decimal_is_comma(); enum symbol_type_t { SymFilename, - SymFunction, SymField, SymLabel, // section, paragraph, or label SymSpecial, SymAlphabet, SymFile, SymDataSection, + SymLocale, }; +// The ISO specification says alphanumeric literals have a maximum length of +// 8,191 characters. It seems to be silent on the length of alphanumeric data +// items. Our implementation requires a maximum length, so we chose to make it +// the same. +#define MAXIMUM_ALPHA_LENGTH 8192 + struct cbl_field_data_t { uint32_t memsize; // nonzero if larger subsequent redefining field uint32_t capacity, // allocated space digits; // magnitude: total digits (or characters) int32_t rdigits; // digits to the right - const char *initial, *picture; + const char *orig, *initial, *picture; enum etc_type_t { val88_e, upsi_e, value_e } etc_type; const char * @@ -270,34 +282,48 @@ struct cbl_field_data_t { val88_t() : false_value(NULL), domain(NULL) {} } val88; struct cbl_upsi_mask_t *upsi_mask; - _Float128 value; + tree value; - explicit etc_t( double v = 0.0 ) : value(v) {} + 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) + , orig(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) , rdigits(0) + , orig(0) , initial(0) , picture(0) , etc_type(value_e) - , etc(0) + , etc() {} cbl_field_data_t( uint32_t memsize, uint32_t capacity, - uint32_t digits, uint32_t rdigits, - const char *initial, - const char *picture = NULL ) + uint32_t digits, uint32_t rdigits, + const char *initial, + const char *picture = NULL ) : memsize(memsize) , capacity(capacity) , digits(digits) , rdigits(rdigits) + , orig(0) , initial(initial) , picture(picture) , etc_type(value_e) - , etc(0) + , etc() {} cbl_field_data_t( const cbl_field_data_t& that ) { @@ -328,17 +354,24 @@ struct cbl_field_data_t { etc_type = upsi_e; return etc.upsi_mask = mask; } - _Float128 value_of() const { + tree value_of() const { if( etc_type != value_e ) { dbgmsg("%s:%d: type is %s", __func__, __LINE__, etc_type_str()); } -//// assert(etc_type == value_e); return etc.value; } - _Float128& operator=( _Float128 v) { + tree& operator=( tree v) { 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); + } time_now_f time_func; @@ -354,21 +387,24 @@ 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(), ',', '.'); } - char *pend = NULL; + double d; + int n; + int erc = sscanf(input.c_str(), "%lf%n", &d, &n); - etc.value = strtof128(input.c_str(), &pend); - - if( pend != input.c_str() + len ) { + if( erc < 0 || size_t(n) != input.size() ) { dbgmsg("%s: error: could not interpret '%s' of '%s' as a number", - __func__, pend, initial); + __func__, initial + n, initial); } + + REAL_VALUE_TYPE r; + real_from_string (&r, input.c_str()); + r = real_value_truncate (TYPE_MODE (float128_type_node), r); + etc.value = build_real (float128_type_node, r); return *this; } cbl_field_data_t& valify( const char *input ) { @@ -378,6 +414,32 @@ struct cbl_field_data_t { return valify(); } + // If initial (of Numeric Edited) has any length but capacity, adjust it. + bool manhandle_initial() { + assert(capacity > 0); + assert(initial != nullptr); + if( capacity < strlen(initial) ) { + char *p = const_cast<char*>(initial); + p[capacity] = '\0'; + return true; + } + if( strlen(initial) < capacity ) { + auto tgt = reinterpret_cast<char *>( xmalloc(capacity + 1) ); + auto pend = tgt + capacity; + auto p = std::copy(initial, initial + strlen(initial), tgt); + std::fill(p, pend, 0x20); + p = pend - 1; + *p = '\0'; + initial = tgt; + } + return false; + } + bool initial_within_capacity() const { + return initial[capacity] == '\0' + || initial[capacity] == '!'; + } + const char *original() const { return orig? orig : initial; } + protected: cbl_field_data_t& copy_self( const cbl_field_data_t& that ) { memsize = that.memsize; @@ -390,14 +452,14 @@ struct cbl_field_data_t { switch(etc_type) { case value_e: - etc.value = that.etc.value; - break; + etc.value = that.etc.value; + break; case val88_e: - etc.val88 = that.etc.val88; - break; + etc.val88 = that.etc.val88; + break; case upsi_e: - etc.upsi_mask = that.etc.upsi_mask; - break; + etc.upsi_mask = that.etc.upsi_mask; + break; } return *this; } @@ -417,8 +479,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; } @@ -451,12 +516,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 ); }; /* @@ -487,17 +552,101 @@ struct cbl_subtable_t { size_t offset, isym; }; +const char * __gg__encoding_iconv_name( cbl_encoding_t encoding ); +bool __gg__encoding_iconv_valid( cbl_encoding_t encoding ); + bool is_elementary( enum cbl_field_type_t type ); +// These were introduced to discourage the use of +// current_encoding('A') and current_encoding('N') +enum + { + display_encoding_e = 'A', + national_encoding_e = 'N' + }; +cbl_encoding_t current_encoding( char a_or_n ); + +/* In cbl_field_t: + * 'offset' is overloaded for FldAlphanumeric/temporary/intermediate variables + * For such variables, offset is a copy of the initial capacity. This is in + * support of the FUNCTION TRIM function, which both needs to be able to + * reduce the capacity of the target variable, and then to reset it back to + * the original value + */ + struct cbl_field_t { size_t offset; - enum cbl_field_type_t type, usage; - size_t attr; + cbl_field_type_t type, usage; + 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() uint32_t level; - struct cbl_occurs_t occurs; + cbl_occurs_t occurs; + struct codeset_t { + static const encodings_t standard_internal, source_encodings[2], *source_encoding; + cbl_encoding_t encoding; + size_t alphabet; // unlikely + explicit codeset_t(cbl_encoding_t encoding = custom_encoding_e, + size_t alphabet = 0) // combination means "not set" + : encoding(encoding), alphabet(alphabet) + {} + bool valid() const { + return + (alphabet == 0 && encoding != custom_encoding_e) + || + (alphabet != 0 && encoding == custom_encoding_e); + } + bool consistent() const { + return valid() && ( encoding == current_encoding('A') + || + encoding == current_encoding('N') + || + encoding == UTF8_e ); + } + bool set( cbl_encoding_t encoding, size_t alphabet = 0 ) { + assert(valid_encoding(encoding)); + if( ! valid() ) { // setting first time + this->encoding = encoding; + this->alphabet = alphabet; + return valid(); + } + return this->encoding == encoding && this->alphabet == alphabet; + } + bool set( const char picture_fragment[] = nullptr) { + if( ! picture_fragment ) { + cbl_encoding_t enc = current_encoding('A'); + bool retval = set(enc); + return retval; + } + size_t len = strlen(picture_fragment); + std::vector<char> frag(len); + std::transform(picture_fragment, picture_fragment + len, + frag.begin(), ftoupper); + switch(frag[0]) { + case 'A': case 'X': case '9': + return set(current_encoding(display_encoding_e)); + case 'N': case 'U': + if( std::all_of(frag.begin(), frag.end(), + [first = frag[0]]( char ch ) { + return first == ch; + } ) ) { + // All N's indicates National; all U's indicates UTF-8. + auto enc = frag[0] == 'N' ? current_encoding(national_encoding_e) + : UTF8_e; + return set(enc); + } + return false; // They all must be the same. + } + gcc_unreachable(); + } + cbl_encoding_t set() const { + return valid()? encoding : cbl_encoding_t(-1); + } + const char *name() const { + return valid()? __gg__encoding_iconv_name(encoding) : "nocoding"; + } + } codeset; int line; // Where it appears in the file. cbl_name_t name; // Appears in the GIMPLE dump. size_t file; // nonzero if field is 01 record for a file @@ -506,19 +655,45 @@ struct cbl_field_t { cbl_ffi_crv_t crv; // Using by C/R/V in Linkage linkage_t() : optional(false), crv(by_default_e) {} } linkage; - struct cbl_field_data_t data; + cbl_field_data_t data; tree var_decl_node; // Reference to the pointer to the cblc_field_t structure 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 + cbl_field_t() + : offset(0), type(FldInvalid), usage(FldInvalid), attr(0) + , parent(0), our_index(0), level(0) + , line(0), name(""), file(0) + , var_decl_node(nullptr), data_decl_node(nullptr) + {} + + cbl_field_t( cbl_field_type_t type, uint64_t attr, + const cbl_field_data_t& data, + uint32_t level = 0, const cbl_name_t name = "", int line = 0 ) + : offset(0), type(type), usage(FldInvalid), attr(attr) + , parent(0), our_index(0), level(level) + , line(line), name(""), file(0), data(data) + , var_decl_node(nullptr), data_decl_node(nullptr) + { + gcc_assert(strlen(name) < sizeof this->name); + strcpy(this->name, name); + } + + cbl_field_t( cbl_field_type_t type, uint32_t level, int line, uint64_t attr = 0 ) + : offset(0), type(type), usage(FldInvalid), attr(attr) + , parent(0), our_index(0), level(level) + , line(line), name(""), file(0) + , var_decl_node(nullptr), data_decl_node(nullptr) + {} void set_linkage( cbl_ffi_crv_t crv, bool optional ) { linkage.optional = optional; linkage.crv = crv; assert(crv != by_content_e); } + bool holds_ascii() const; + inline bool is_typedef() const { return has_attr(typedef_e); } @@ -536,6 +711,10 @@ struct cbl_field_t { || type == FldLiteralN; } + bool is_zero() const { + return real_zerop(data.value_of()); + } + bool rename_level_ok() const { switch( level ) { case 0: @@ -558,10 +737,11 @@ struct cbl_field_t { attr |= same_as_e; data = that.data; - + codeset = that.codeset; + if( ! (is_typedef || that.type == FldClass) ) { data.initial = NULL; - data = _Float128(0.0); + data = build_zero_cst (float128_type_node); } return *this; } @@ -575,6 +755,10 @@ struct cbl_field_t { return type == FldNumericBinary || type == FldNumericBin5; } + HOST_WIDE_INT as_integer() const { + return real_to_integer( TREE_REAL_CST_PTR (data.value_of()) ); + } + void embiggen( size_t eight=8 ) { assert(gcobol_feature_embiggen() && is_numeric(type) && size() == 4); @@ -587,8 +771,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 { @@ -600,7 +784,6 @@ struct cbl_field_t { bool has_subordinate( const cbl_field_t *that ) const; const char * internalize(); - bool value_set( _Float128 value ); const char *value_str() const; bool is_key_name() const { return has_attr(record_key_e); } @@ -614,7 +797,7 @@ struct cbl_field_t { uint32_t size() const; // table capacity or capacity const char * pretty_name() const { - if( name[0] == '_' && data.initial ) return data.initial; + if( name[0] == '_' && data.original() ) return data.original(); return name; } static const char * level_str(uint32_t level ); @@ -623,6 +806,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; @@ -630,7 +815,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 ); } @@ -644,50 +829,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[] ) { @@ -698,8 +897,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 ); @@ -764,7 +963,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_" @@ -774,9 +973,6 @@ 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); - static inline bool is_constant( const cbl_field_t *field ) { return field->has_attr(constant_e); @@ -793,17 +989,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 { @@ -824,6 +1023,7 @@ enum cbl_label_type_t { LblString, LblArith, LblCompute, + LblXml, }; struct cbl_proc_addresses_t { @@ -900,8 +1100,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() ) @@ -934,7 +1138,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 ); @@ -946,8 +1153,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 ); @@ -1035,11 +1243,24 @@ struct cbl_arith_error_t { cbl_label_addresses_t bottom; }; +struct cbl_delete_file_t { + cbl_label_addresses_t over; + cbl_label_addresses_t exception; + cbl_label_addresses_t no_exception; + cbl_label_addresses_t bottom; +}; + struct cbl_compute_error_t { // This is an int. The value is a cbl_compute_error_code_t tree compute_error_code; }; +struct cbl_xml_parse_t { + cbl_label_addresses_t over; + cbl_label_addresses_t exception; + cbl_label_addresses_t no_exception; +}; + struct cbl_label_t { enum cbl_label_type_t type; size_t parent; @@ -1073,6 +1294,13 @@ struct cbl_label_t { // for parser_op/parser_assign error tracking struct cbl_compute_error_t *compute_error; + + // for parse_xml processing: + struct cbl_xml_parse_t *xml_parse; + + // For parser_file_delete_file + struct cbl_delete_file_t *delete_file; + } structs; bool is_function() const { return type == LblFunction; } @@ -1091,6 +1319,7 @@ struct cbl_label_t { case LblString: return "LblString"; case LblArith: return "LblArith"; case LblCompute: return "LblCompute"; + case LblXml: return "LblXml"; } gcc_unreachable(); } @@ -1145,30 +1374,48 @@ struct label_cmp_lessthan { size_t field_index( const cbl_field_t *f ); -cbl_field_t * new_temporary( enum cbl_field_type_t type, const char initial[] = NULL ); +cbl_field_t * new_temporary( enum cbl_field_type_t type, + const char initial[] = NULL, + bool attr = false ); cbl_field_t * new_temporary_like( cbl_field_t skel ); cbl_field_t * new_temporary_clone( const cbl_field_t *orig); cbl_field_t * keep_temporary( cbl_field_type_t type ); cbl_field_t * new_literal( uint32_t len, const char initial[], - enum cbl_field_attr_t attr = none_e ); + cbl_field_attr_t attr, + cbl_encoding_t encoding = ASCII_e ); + +static inline cbl_field_t * +new_literal( uint32_t len, const char initial[] ) { + return new_literal(len, initial, none_e); +} void symbol_temporaries_free(); class temporaries_t { friend void symbol_temporaries_free(); struct literal_an { - bool is_quoted; + bool is_quoted, is_verbatim; // verbatim: don't use codeset std::string value; - literal_an( const char value[] = "???", bool is_quoted = false ) - : is_quoted(is_quoted), value(value) {} + literal_an() : is_quoted(false), is_verbatim(false), value("???") {} + literal_an( const char value[], bool is_quoted, bool is_verbatim = false ) + : is_quoted(is_quoted), is_verbatim(is_verbatim), value(value) {} + literal_an( const literal_an& that ) + : is_quoted(that.is_quoted), + is_verbatim(that.is_verbatim), + value(that.value) + {} literal_an& operator=( const literal_an& that ) { is_quoted = that.is_quoted; + is_verbatim = that.is_verbatim; value = that.value; return *this; } bool operator<( const literal_an& that ) const { if( value == that.value ) { // alpha before numeric + if( is_quoted == that.is_quoted ) { // verbatim before not + return (is_verbatim? 0 : 1) < (that.is_verbatim? 0 : 1); + } return (is_quoted? 0 : 1) < (that.is_quoted? 0 : 1); } return value < that.value; @@ -1181,9 +1428,10 @@ class temporaries_t { fieldmap_t used, freed; public: - cbl_field_t * literal( const char value[], uint32_t len, cbl_field_attr_t attr = none_e ); + cbl_field_t * literal( uint32_t len, const char value[], + cbl_field_attr_t attr, cbl_encoding_t encoding ); 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; @@ -1264,7 +1512,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 ? } @@ -1283,7 +1532,6 @@ struct function_descr_t { case FldForward: case FldIndex: case FldSwitch: - case FldBlob: return '?'; case FldPointer: return 'O'; @@ -1334,14 +1582,18 @@ struct cbl_section_t { } gcc_unreachable(); } - uint32_t attr() const { - switch(type) { - case file_sect_e: - case working_sect_e: return 0; - case linkage_sect_e: return linkage_e; - case local_sect_e: return local_e; - } - gcc_unreachable(); +}; + +struct cbl_locale_t { + cbl_name_t name; + cbl_encoding_t encoding; + cbl_name_t collation; + + explicit cbl_locale_t(const cbl_name_t name, + const char iconv_name[] = nullptr ); + + bool operator<( const cbl_locale_t& that ) const { + return strcmp(name, that.name) < 0; } }; @@ -1355,62 +1607,95 @@ struct cbl_special_name_t { char * hex_decode( const char text[] ); +/* + * An alphabet may just name an encoding, which implies binary collation. + * + * An alphabet may reference a Special-Names LOCALE, which defines an encoding + * and a collation (perhaps by default). + * + * During Special-Names parsing, an Alphabet may reference an as-yet undefined + * LOCALE with an as-yet unknown encoding. As a placeholder it inserts a named, + * undefined cbl_locale_t symbol, which the Alphabet references. If that + * locale is never defined, the encoding remains unknown, resulting in an error + * diagnostic at the end of Special-Names. + * + * For a custom alphabet of single-byte encoding, cbl_alphabet_t::collation_sequence + * holds the collation position of each encoded value. + * If 'A' sorts first (after LOW-VALUE), then collation_sequence['A'] == 1. + * If the encoding is ASCII, then 'A' is 65 and collation_sequence[ 65] == 1. + * If the encoding is EBCDIC CP1140, then 'A' is 193 and collation_sequence[193] == 1. + */ struct cbl_alphabet_t { YYLTYPE loc; cbl_name_t name; cbl_encoding_t encoding; - unsigned char low_index, high_index, last_index, alphabet[256]; + size_t locale; // index to cbl_locale_t symbol + unsigned char low_index, high_index, last_index, collation_sequence[256]; + unsigned char low_char, high_char; cbl_alphabet_t() : loc { 1,1, 1,1 } , encoding(ASCII_e) + , locale(0) , low_index(0) , high_index(255) , last_index(0) + , low_char(0) + , high_char(0) { memset(name, '\0', sizeof(name)); - memset(alphabet, 0xFF, sizeof(alphabet)); + memset(collation_sequence, 0xFF, sizeof(collation_sequence)); } cbl_alphabet_t(const YYLTYPE& loc, cbl_encoding_t enc) : loc(loc) , encoding(enc) + , locale(0) , low_index(0) , high_index(255) , last_index(0) + , low_char(0) + , high_char(0) { memset(name, '\0', sizeof(name)); - memset(alphabet, 0xFF, sizeof(alphabet)); + memset(collation_sequence, 0xFF, sizeof(collation_sequence)); } + cbl_alphabet_t(const YYLTYPE& loc, size_t locale, cbl_name_t name ); + cbl_alphabet_t( const YYLTYPE& loc, const cbl_name_t name, unsigned char low_index, unsigned char high_index, - unsigned char alphabet[] ) + unsigned char collation_sequence[] ) : loc(loc) , encoding(custom_encoding_e) + , locale(0) , low_index(low_index), high_index(high_index) , last_index(high_index) + , low_char(low_index) + , high_char(high_index) { assert(strlen(name) < sizeof(this->name)); strcpy(this->name, name); - std::copy(alphabet, alphabet + sizeof(this->alphabet), this->alphabet); + std::copy(collation_sequence, + collation_sequence + sizeof(this->collation_sequence), + this->collation_sequence); } unsigned char low_value() const { - return alphabet[low_index]; + return collation_sequence[low_index]; } unsigned char high_value() const { - return alphabet[high_index]; + return collation_sequence[high_index]; } void 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? collation_sequence[last_index] + 1 : 0; for( const unsigned char *p = seq; !end_of_string(p); p++ ) { - assign(loc, *p, high_value++); + assign(loc, *p, last++); } } @@ -1418,15 +1703,16 @@ 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 = collation_sequence[last_index]; for( unsigned char ch = low; ch < high; ch++ ) { - assign(loc, ch, high_value++); + assign(loc, ch, last++); } } void also( const YYLTYPE& loc, size_t ch ); bool assign( const YYLTYPE& loc, unsigned char ch, unsigned char value ); + void reencode(); static const char * encoding_str( cbl_encoding_t encoding ) { @@ -1434,22 +1720,31 @@ struct cbl_alphabet_t { case ASCII_e: return "ascii"; case iso646_e: return "iso646"; case EBCDIC_e: return "ebcdic"; + case UTF8_e: return "utf8"; case custom_encoding_e: return "custom"; + default: + { + auto p = __gg__encoding_iconv_name( encoding ); + if( p ) return p; + } } return "???"; } void dump() const { - yywarn("'%s': %s, '%c' to '%c' (low 0x%02x, high 0x%02x)", - name, encoding_str(encoding), - low_index, last_index, low_index, high_index); + dbgmsg("%s: '%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 ) { fprintf(stderr, "\t" " 0 1 2 3 4 5 6 7" " 8 9 A B C C E F"); unsigned int row = 0; - for( auto p = alphabet; p < alphabet + sizeof(alphabet); p++ ) { - if( (p - alphabet) % 16 == 0 ) fprintf(stderr, "\n%4X\t", row++); + for( auto p = collation_sequence; + p < collation_sequence + sizeof(collation_sequence); p++ ) { + if( (p - collation_sequence) % 16 == 0 ) { + fprintf(stderr, "\n%4X\t", row++); + } fprintf(stderr, "%3u ", *p); } fprintf(stderr, "\n"); @@ -1463,14 +1758,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 ) { @@ -1509,9 +1796,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) @@ -1520,20 +1817,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; @@ -1547,12 +1858,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; @@ -1573,21 +1884,45 @@ struct cbl_file_t { size_t user_status; // index into symbol table for file status size_t vsam_status; // index into symbol table for vsam status PIC X(6) size_t record_length; // DEPENDS ON + struct codeset_t { + cbl_encoding_t encoding; + size_t alphabet; // unlikely + explicit codeset_t(cbl_encoding_t encoding = CP1252_e, size_t alphabet = 0) + : encoding(encoding), alphabet(alphabet) + {} + } codeset; int line; cbl_name_t name; cbl_sortreturn_t *addresses; // Used during parser_return_start, et al. 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; @@ -1626,20 +1961,18 @@ 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_locale_t locale; 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) {} @@ -1680,9 +2013,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; @@ -1692,6 +2022,9 @@ struct symbol_elem_t { case SymSpecial: elem.special = that.elem.special; break; + case SymLocale: + elem.locale = that.elem.locale; + break; case SymAlphabet: elem.alphabet = that.elem.alphabet; break; @@ -1712,6 +2045,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); } @@ -1719,6 +2053,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); } @@ -1726,6 +2061,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); } @@ -1733,19 +2069,30 @@ 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); } +static inline const symbol_elem_t * +symbol_elem_of( const cbl_alphabet_t *alphabet ) { + size_t n = offsetof(symbol_elem_t, elem.alphabet); + return + // cppcheck-suppress cstyleCast + reinterpret_cast<const symbol_elem_t *>((const char*)alphabet - n); +} + 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); } @@ -1753,18 +2100,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 ); @@ -1780,7 +2129,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(); @@ -1802,63 +2151,79 @@ const cbl_label_t * symbol_program_local( const char called[] ); bool redefine_field( cbl_field_t *field ); -// Functions to correctly extract the underlying type. -static inline struct cbl_function_t * -cbl_function_of( struct symbol_elem_t *e ) { - assert(e->type == SymFunction); - return &e->elem.function; -} +const cbl_field_t * +symbol_unresolved_file_key( const cbl_file_t * file, + const cbl_name_t key_field_name ); -static inline struct cbl_section_t * -cbl_section_of( struct symbol_elem_t *e ) { - assert(e->type == SymDataSection); +static inline cbl_section_t * +cbl_section_of( symbol_elem_t *e ) { + 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); +static inline cbl_field_t * +cbl_field_of( symbol_elem_t *e ) { + 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); +static inline cbl_label_t * +cbl_label_of( symbol_elem_t *e ) { + 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); +static inline cbl_special_name_t * +cbl_special_name_of( symbol_elem_t *e ) { + 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); +static inline cbl_locale_t * +cbl_locale_of( symbol_elem_t *e ) { + assert(e && e->type == SymLocale); + return &e->elem.locale; +} + +static inline const cbl_locale_t * +cbl_locale_of( const symbol_elem_t *e ) { + assert(e && e->type == SymLocale); + return &e->elem.locale; +} + +static inline cbl_alphabet_t * +cbl_alphabet_of( symbol_elem_t *e ) { + assert(e && e->type == SymAlphabet); + return &e->elem.alphabet; +} + +static inline const cbl_alphabet_t * +cbl_alphabet_of( const symbol_elem_t *e ) { + 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); + +static inline cbl_file_t * +cbl_file_of( symbol_elem_t *e ) { + 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; } @@ -1877,43 +2242,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); } @@ -1933,7 +2298,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 @@ -1941,7 +2306,9 @@ 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 ); +size_t symbol_unique_index( const struct symbol_elem_t *e ); + struct symbol_elem_t * symbol_at( size_t index ); struct cbl_options_t { @@ -1993,17 +2360,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(); }; @@ -2015,13 +2385,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)); @@ -2040,11 +2408,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() ); } } @@ -2058,10 +2427,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) @@ -2083,12 +2453,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; } @@ -2109,7 +2479,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); @@ -2196,6 +2566,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(); @@ -2216,10 +2590,11 @@ struct symbol_elem_t * symbol_literalA( size_t program, const char name[] ); struct cbl_special_name_t * symbol_special( special_name_t id ); struct symbol_elem_t * symbol_special( size_t program, const char name[] ); +struct symbol_elem_t * symbol_locale( 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 ); @@ -2229,7 +2604,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 ); @@ -2237,12 +2612,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; } @@ -2254,21 +2629,22 @@ 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_locale_add( size_t program, const cbl_locale_t *locale ); +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 ); @@ -2287,25 +2663,186 @@ static inline size_t upsi_register() { return symbol_index(symbol_field(0,0,"UPSI-0")); } -void wsclear( char ch); -const char *wsclear(); +void wsclear( uint32_t ch); +const uint32_t *wsclear(); enum cbl_call_convention_t { cbl_call_verbatim_e = 'V', cbl_call_cobol_e = 'N', // native }; +int keyword_tok( const char * text, bool include_intrinsics = false ); +int redefined_token( const cbl_name_t name ); + +class current_tokens_t { + class tokenset_t { + // token_names is initialized from a generated header file. + std::vector<const char *>token_names; // position indicates token value + std::map <std::string, int> tokens; // aliases + std::set<std::string> cobol_words; // Anything in COBOL-WORDS may appear only once. + public: + static std::string + lowercase( const cbl_name_t name ) { + cbl_name_t lname; + std::transform(name, name + strlen(name) + 1, lname, ftolower); + return lname; + } + static std::string + uppercase( const cbl_name_t name ) { + cbl_name_t uname; + std::transform(name, name + strlen(name) + 1, uname, ftoupper); + return uname; + } + + public: + tokenset_t(); + int find( const cbl_name_t name, bool include_intrinsics ); + + bool equate( const YYLTYPE& loc, int token, + const cbl_name_t name, const cbl_name_t verb = "EQUATE") { + auto lname( lowercase(name) ); + auto cw = cobol_words.insert(lname); + if( ! cw.second ) { + error_msg(loc, "COBOL-WORDS %s: %s may appear but once", verb, name); + return false; + } + auto p = tokens.find(lowercase(name)); + bool fOK = p == tokens.end(); + if( fOK ) { // name not already in use + tokens[lname] = token; + dbgmsg("%s:%d: %d has alias %s", __func__, __LINE__, token, name); + } else { + error_msg(loc, "%s: %s already defined as a token", verb, name); + } + return fOK; + } + bool undefine( const YYLTYPE& loc, + const cbl_name_t name, const cbl_name_t verb = "UNDEFINE" ) { + auto lname( lowercase(name) ); + auto cw = cobol_words.insert(lname); + if( ! cw.second ) { + error_msg(loc, "COBOL-WORDS %s: %s may appear but once", verb, name); + return false; + } + + // Do not erase generic, multi-type tokens COMPUTATIONAL and BINARY_INTEGER. + if( binary_integer_usage_of(name) ) { + dbgmsg("%s:%d: generic %s remains valid as a token", __func__, __LINE__, name); + return true; + } + + auto p = tokens.find(lname); + bool fOK = p != tokens.end(); + if( fOK ) { // name in use + tokens.erase(p); + } else { + error_msg(loc, "%s: %s not defined as a token", verb, name); + } + dbgmsg("%s:%d: %s removed as a valid token name", __func__, __LINE__, name); + return fOK; + } + + bool substitute( const YYLTYPE& loc, + const cbl_name_t extant, int token, const cbl_name_t name ) { + return + equate( loc, token, name, "SUBSTITUTE" ) + && + undefine( loc, extant, "SUBSTITUTE" ); + } + bool reserve( const YYLTYPE& loc, const cbl_name_t name ) { + auto lname( lowercase(name) ); + auto cw = cobol_words.insert(lname); + if( ! cw.second ) { + error_msg(loc, "COBOL-WORDS RESERVE: %s may appear but once", name); + return false; + } + tokens[lname] = -42; + return true; + } + int redefined_as( const cbl_name_t name ) { + auto lname( lowercase(name) ); + if( cobol_words.find(lname) != cobol_words.end() ) { + auto p = tokens.find(lname); + if( p != tokens.end() ) { + return p->second; + } + } + return 0; + } + const char * name_of( int tok ) const { + tok -= (255 + 3); + gcc_assert(0 <= tok && size_t(tok) < token_names.size()); + return tok < 0? "???" : token_names[tok]; + } + }; + + tokenset_t tokens; + public: + current_tokens_t() {} + int find( const cbl_name_t name, bool include_intrinsics ) { + return tokens.find(name, include_intrinsics); + } + bool equate( const YYLTYPE& loc, const cbl_name_t keyword, const cbl_name_t alias ) { + int token; + if( 0 == (token = binary_integer_usage_of(keyword)) ) { + if( 0 == (token = keyword_tok(keyword)) ) { + error_msg(loc, "EQUATE %s: not a valid token", keyword); + return false; + } + } + auto name = keyword_alias_add(tokens.uppercase(keyword), + tokens.uppercase(alias)); + if( name != keyword ) { + error_msg(loc, "EQUATE: %s is already an alias for %s", alias, name.c_str()); + return false; + } + return tokens.equate(loc, token, alias); + } + bool undefine( const YYLTYPE& loc, cbl_name_t keyword ) { + return tokens.undefine(loc, keyword); + } + bool substitute( const YYLTYPE& loc, const cbl_name_t keyword, const cbl_name_t alias ) { + int token; + if( 0 == (token = binary_integer_usage_of(keyword)) ) { + if( 0 == (token = keyword_tok(keyword)) ) { + error_msg(loc, "SUBSTITUTE %s: not a valid token", keyword); + return false; + } + } + auto name = keyword_alias_add(tokens.uppercase(keyword), + tokens.uppercase(alias)); + if( name != keyword ) { + error_msg(loc, "SUBSTITUTE: %s is already an alias for %s", alias, name.c_str()); + return false; + } + + dbgmsg("%s:%d: %s (%d) will have alias %s", __func__, __LINE__, keyword, token, alias); + return tokens.substitute(loc, keyword, token, alias); + } + bool reserve( const YYLTYPE& loc, const cbl_name_t name ) { + return tokens.reserve(loc, name); + } + int redefined_as( const cbl_name_t name ) { + return tokens.redefined_as(name); + } + const char * name_of( int tok ) const { + return tokens.name_of(tok); + } +}; + cbl_call_convention_t current_call_convention(); +current_tokens_t& cdf_current_tokens(); -cbl_call_convention_t +void current_call_convention( cbl_call_convention_t convention); class procref_base_t { private: const char *section_name, *paragraph_name; public: - procref_base_t( const char *section_name = NULL, - const char *paragraph_name = NULL ) + procref_base_t() : section_name(nullptr) , paragraph_name(nullptr) {} + procref_base_t( const char *section_name, + const char *paragraph_name ) : section_name(section_name) , paragraph_name(paragraph_name) {} @@ -2340,9 +2877,6 @@ public: int line_number() const { return line; } }; -int keyword_tok( const char * text, bool include_intrinsics = false ); -int redefined_token( const cbl_name_t name ); - void procedure_definition_add( size_t program, const cbl_label_t *procedure ); void procedure_reference_add( const char *sect, const char *para, int line, size_t context ); @@ -2358,12 +2892,8 @@ symbol_field_same_as( cbl_field_t *tgt, const cbl_field_t *src ); size_t symbol_file_same_record_area( std::list<cbl_file_t*>& files ); -cbl_field_t * -symbol_valid_udf_args( size_t function, - std::list<cbl_refer_t> args = std::list<cbl_refer_t>() ); - bool symbol_currency_add( const char symbol[], const char sign[] = NULL ); -const char * symbol_currency( char symbol ); +const char * symbol_currency( char symbol = '\0' ); const char * symbol_type_str( enum symbol_type_t type ); const char * cbl_field_type_str( enum cbl_field_type_t type ); @@ -2376,7 +2906,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); @@ -2391,4 +2921,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 38a8900..472d37a 100644 --- a/gcc/cobol/symfind.cc +++ b/gcc/cobol/symfind.cc @@ -31,6 +31,9 @@ #include "cobol-system.h" +#include "coretypes.h" +#include "tree.h" + #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" #include "util.h" @@ -45,7 +48,7 @@ extern int yydebug; static bool is_data_field( symbol_elem_t& e ) { if( e.type != SymField ) return false; - auto f = cbl_field_of(&e); + const cbl_field_t *f = cbl_field_of(&e); if( f->name[0] == '\0' ) return false; if( is_filler(f) ) return false; @@ -125,11 +128,10 @@ finalize_symbol_map2() { for( auto& elem : symbol_map2 ) { auto& fields( elem.second ); - std::remove_if( fields.begin(), fields.end(), - []( auto isym ) { - auto f = cbl_field_of(symbol_at(isym)); - return f->type == FldInvalid; - } ); + fields.remove_if( []( auto isym ) { + const cbl_field_t *f = cbl_field_of(symbol_at(isym)); + return f->type == FldInvalid; + } ); if( fields.empty() ) empties.insert(elem.first); } @@ -145,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); } @@ -177,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); } @@ -198,15 +202,10 @@ 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); + assert(field->type != FldForward); // eliminated by is_data_field symbol_map_t::key_type key( sym.program, field->name, field->parent ); symbol_map_t::value_type elem( key, std::vector<size_t>() ); @@ -231,25 +230,9 @@ 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; } -void erase_symbol_map_fwds( size_t beg ) { - for( auto p = symbols_begin(beg); p < symbols_end(); p++ ) { - if( p->type != SymField ) continue; - const auto& field(*cbl_field_of(p)); - if( field.type == FldForward ) { - symbol_map.erase( sym_name_t(p->program, field.name, field.parent) ); - } - } -} - void build_symbol_map() { static size_t beg = 0; @@ -266,14 +249,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() ); } } @@ -286,18 +266,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 ); } }; @@ -312,7 +289,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(), @@ -330,9 +307,9 @@ public: if( p != item.second.end() ) { // Preserve symbol's index at front of ancestor list. symbol_map_t::mapped_type shorter(1 + ancestors->size()); - auto p = shorter.begin(); - *p = item.second.front(); - shorter.insert( ++p, ancestors->begin(), ancestors->end() ); + auto p_l = shorter.begin(); + *p_l = item.second.front(); + shorter.insert( ++p_l, ancestors->begin(), ancestors->end() ); return make_pair(item.first, shorter); } } @@ -345,7 +322,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); } @@ -355,16 +332,16 @@ class in_scope { size_t program; static size_t prog_of( size_t program ) { - auto L = cbl_label_of(symbol_at(program)); + const cbl_label_t *L = cbl_label_of(symbol_at(program)); return L->parent; } public: - in_scope( size_t program ) : program(program) {} + explicit in_scope( size_t program ) : program(program) {} // A symbol is in scope if it's defined by this program or by an ancestor. bool operator()( const symbol_map_t::value_type& item ) const { - symbol_elem_t *e = symbol_at(item.second.front()); + const symbol_elem_t *e = symbol_at(item.second.front()); for( size_t prog = this->program; prog != 0; prog = prog_of(prog) ) { if( e->program == prog ) return true; } @@ -435,7 +412,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; @@ -444,7 +421,7 @@ symbol_match2( size_t program, auto plist = symbol_map2.find(key); if( plist != symbol_map2.end() ) { for( auto candidate : plist->second ) { - auto e = symbol_at(candidate); + const symbol_elem_t *e = symbol_at(candidate); if( name_has_names( e, names, local ) ) { fields.push_back( symbol_index(e) ); } @@ -478,14 +455,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); @@ -500,7 +479,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; @@ -516,7 +495,7 @@ symbol_match( size_t program, std::list<const char *> names ) { } auto inserted = output.insert(*p); if( ! inserted.second ) { - yyerror("%s is not a unique reference", key.name); + error_msg_direct("%s is not a unique reference", key.name); } } return output; @@ -551,13 +530,13 @@ symbol_find( size_t program, std::list<const char *> names ) { auto unique = items.size() == 1; - if( !unique ) { + if( ! unique ) { if( items.empty() ) { 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 ); } } @@ -573,7 +552,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(), @@ -585,12 +564,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) ); @@ -602,8 +575,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 26dabc8..8ce6472 100644 --- a/gcc/cobol/token_names.h +++ b/gcc/cobol/token_names.h @@ -1,1373 +1,1412 @@ -// generated by ./token_names.h.gen ../../build/gcc/cobol/parse.h -// Fri Jan 31 05:52:10 EST 2025 +// generated by /home/jklowden/projects/3rd/gcc/parser/gcc/cobol/token_names.h.gen cobol/parse.h +// Wed Nov 26 11:57:23 EST 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 }, // 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 }, // 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 }, // 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 + { "eq", EQ }, // 298 + { "literal", LITERAL }, // 299 + { "end", END }, // 300 + { "eop", EOP }, // 301 + { "filename", FILENAME }, // 302 + { "invalid", INVALID }, // 303 + { "number", NUMBER }, // 304 + { "negative", NEGATIVE }, // 305 + { "numstr", NUMSTR }, // 306 + { "overflow", OVERFLOW_kw }, // 307 + { "binary-integer", BINARY_INTEGER }, // 308 + { "computational", COMPUTATIONAL }, // 309 + { "perform", PERFORM }, // 310 + { "backward", BACKWARD }, // 311 + { "positive", POSITIVE }, // 312 + { "pointer", POINTER }, // 313 + { "section", SECTION }, // 314 + { "standard-alphabet", STANDARD_ALPHABET }, // 315 + { "switch", SWITCH }, // 316 + { "upsi", UPSI }, // 317 + { "zero", ZERO }, // 318 + { "zeros", ZERO }, // 318 + { "zeroes", ZERO }, // 318 + { "sysin", SYSIN }, // 319 + { "sysipt", SYSIPT }, // 320 + { "sysout", SYSOUT }, // 321 + { "syslist", SYSLIST }, // 322 + { "syslst", SYSLST }, // 323 + { "syspunch", SYSPUNCH }, // 324 + { "syspch", SYSPCH }, // 325 + { "console", CONSOLE }, // 326 + { "c01", C01 }, // 327 + { "c02", C02 }, // 328 + { "c03", C03 }, // 329 + { "c04", C04 }, // 330 + { "c05", C05 }, // 331 + { "c06", C06 }, // 332 + { "c07", C07 }, // 333 + { "c08", C08 }, // 334 + { "c09", C09 }, // 335 + { "c10", C10 }, // 336 + { "c11", C11 }, // 337 + { "c12", C12 }, // 338 + { "csp", CSP }, // 339 + { "s01", S01 }, // 340 + { "s02", S02 }, // 341 + { "s03", S03 }, // 342 + { "s04", S04 }, // 343 + { "s05", S05 }, // 344 + { "afp-5a", AFP_5A }, // 345 + { "stdin", STDIN }, // 346 + { "stdout", STDOUT }, // 347 + { "stderr", STDERR }, // 348 + { "list", LIST }, // 349 + { "map", MAP }, // 350 + { "nolist", NOLIST }, // 351 + { "nomap", NOMAP }, // 352 + { "nosource", NOSOURCE }, // 353 + { "might-be", MIGHT_BE }, // 354 + { "function-udf", FUNCTION_UDF }, // 355 + { "function-udf-0", FUNCTION_UDF_0 }, // 356 + { "default", DEFAULT }, // 357 + { "date-fmt", DATE_FMT }, // 358 + { "time-fmt", TIME_FMT }, // 359 + { "datetime-fmt", DATETIME_FMT }, // 360 + { "basis", BASIS }, // 361 + { "cbl", CBL }, // 362 + { "constant", CONSTANT }, // 363 + { "copy", COPY }, // 364 + { "defined", DEFINED }, // 365 + { "enter", ENTER }, // 366 + { "feature", FEATURE }, // 367 + { "insertt", INSERTT }, // 368 + { "lsub", LSUB }, // 369 + { "parameter", PARAMETER_kw }, // 370 + { "override", OVERRIDE }, // 371 + { "ready", READY }, // 372 + { "reset", RESET }, // 373 + { "rsub", RSUB }, // 374 + { "service-reload", SERVICE_RELOAD }, // 375 + { "star-cbl", STAR_CBL }, // 376 + { "subscript", SUBSCRIPT }, // 377 + { "suppress", SUPPRESS }, // 378 + { "title", TITLE }, // 379 + { "trace", TRACE }, // 380 + { "use", USE }, // 381 + { "cobol-words", COBOL_WORDS }, // 382 + { "equate", EQUATE }, // 383 + { "undefine", UNDEFINE }, // 384 + { "cdf-define", CDF_DEFINE }, // 385 + { "cdf-display", CDF_DISPLAY }, // 386 + { "cdf-if", CDF_IF }, // 387 + { "cdf-else", CDF_ELSE }, // 388 + { "cdf-end-if", CDF_END_IF }, // 389 + { "cdf-evaluate", CDF_EVALUATE }, // 390 + { "cdf-when", CDF_WHEN }, // 391 + { "cdf-end-evaluate", CDF_END_EVALUATE }, // 392 + { "call-convention", CALL_CONVENTION }, // 393 + { "call-cobol", CALL_COBOL }, // 394 + { "call-verbatim", CALL_VERBATIM }, // 395 + { "cdf-push", CDF_PUSH }, // 396 + { "cdf-pop", CDF_POP }, // 397 + { "source-format", SOURCE_FORMAT }, // 398 + { "if", IF }, // 399 + { "then", THEN }, // 400 + { "else", ELSE }, // 401 + { "sentence", SENTENCE }, // 402 + { "accept", ACCEPT }, // 403 + { "add", ADD }, // 404 + { "alter", ALTER }, // 405 + { "call", CALL }, // 406 + { "cancel", CANCEL }, // 407 + { "close", CLOSE }, // 408 + { "compute", COMPUTE }, // 409 + { "continue", CONTINUE }, // 410 + { "delete", DELETE }, // 411 + { "display", DISPLAY }, // 412 + { "divide", DIVIDE }, // 413 + { "evaluate", EVALUATE }, // 414 + { "exit", EXIT }, // 415 + { "filler", FILLER_kw }, // 416 + { "goback", GOBACK }, // 417 + { "goto", GOTO }, // 418 + { "initialize", INITIALIZE }, // 419 + { "inspect", INSPECT }, // 420 + { "merge", MERGE }, // 421 + { "move", MOVE }, // 422 + { "multiply", MULTIPLY }, // 423 + { "open", OPEN }, // 424 + { "paragraph", PARAGRAPH }, // 425 + { "read", READ }, // 426 + { "release", RELEASE }, // 427 + { "return", RETURN }, // 428 + { "rewrite", REWRITE }, // 429 + { "search", SEARCH }, // 430 + { "set", SET }, // 431 + { "select", SELECT }, // 432 + { "sort", SORT }, // 433 + { "sort-merge", SORT_MERGE }, // 434 + { "string", STRING_kw }, // 435 + { "stop", STOP }, // 436 + { "subtract", SUBTRACT }, // 437 + { "start", START }, // 438 + { "unstring", UNSTRING }, // 439 + { "write", WRITE }, // 440 + { "when", WHEN }, // 441 + { "argument-number", ARGUMENT_NUMBER }, // 442 + { "argument-value", ARGUMENT_VALUE }, // 443 + { "environment-name", ENVIRONMENT_NAME }, // 444 + { "environment-value", ENVIRONMENT_VALUE }, // 445 + { "abs", ABS }, // 446 + { "access", ACCESS }, // 447 + { "acos", ACOS }, // 448 + { "actual", ACTUAL }, // 449 + { "advancing", ADVANCING }, // 450 + { "after", AFTER }, // 451 + { "all", ALL }, // 452 + { "allocate", ALLOCATE }, // 453 + { "alphabet", ALPHABET }, // 454 + { "alphabetic", ALPHABETIC }, // 455 + { "alphabetic-lower", ALPHABETIC_LOWER }, // 456 + { "alphabetic-upper", ALPHABETIC_UPPER }, // 457 + { "alphanumeric", ALPHANUMERIC }, // 458 + { "alphanumeric-edited", ALPHANUMERIC_EDITED }, // 459 + { "also", ALSO }, // 460 + { "alternate", ALTERNATE }, // 461 + { "annuity", ANNUITY }, // 462 + { "anum", ANUM }, // 463 + { "any", ANY }, // 464 + { "anycase", ANYCASE }, // 465 + { "apply", APPLY }, // 466 + { "are", ARE }, // 467 + { "area", AREA }, // 468 + { "areas", AREAS }, // 469 + { "as", AS }, // 470 + { "ascending", ASCENDING }, // 471 + { "activating", ACTIVATING }, // 472 + { "asin", ASIN }, // 473 + { "assign", ASSIGN }, // 474 + { "at", AT }, // 475 + { "atan", ATAN }, // 476 + { "based", BASED }, // 477 + { "baseconvert", BASECONVERT }, // 478 + { "before", BEFORE }, // 479 + { "binary", BINARY }, // 480 + { "bit", BIT }, // 481 + { "bit-of", BIT_OF }, // 482 + { "bit-to-char", BIT_TO_CHAR }, // 483 + { "blank", BLANK }, // 484 + { "block", BLOCK_kw }, // 485 + { "boolean-of-integer", BOOLEAN_OF_INTEGER }, // 486 + { "bottom", BOTTOM }, // 487 + { "by", BY }, // 488 + { "byte", BYTE }, // 489 + { "byte-length", BYTE_LENGTH }, // 490 + { "cf", CF }, // 491 + { "ch", CH }, // 492 + { "changed", CHANGED }, // 493 + { "char", CHAR }, // 494 + { "char-national", CHAR_NATIONAL }, // 495 + { "character", CHARACTER }, // 496 + { "characters", CHARACTERS }, // 497 + { "checking", CHECKING }, // 498 + { "class", CLASS }, // 499 + { "cobol", COBOL }, // 500 + { "code", CODE }, // 501 + { "code-set", CODESET }, // 502 + { "collating", COLLATING }, // 503 + { "column", COLUMN }, // 504 + { "combined-datetime", COMBINED_DATETIME }, // 505 + { "comma", COMMA }, // 506 + { "command-line", COMMAND_LINE }, // 507 + { "command-line-count", COMMAND_LINE_COUNT }, // 508 + { "commit", COMMIT }, // 509 + { "common", COMMON }, // 510 + { "concat", CONCAT }, // 511 + { "condition", CONDITION }, // 512 + { "configuration", CONFIGURATION_SECT }, // 513 + { "contains", CONTAINS }, // 514 + { "content", CONTENT }, // 515 + { "control", CONTROL }, // 516 + { "controls", CONTROLS }, // 517 + { "convert", CONVERT }, // 518 + { "converting", CONVERTING }, // 519 + { "corresponding", CORRESPONDING }, // 520 + { "cos", COS }, // 521 + { "count", COUNT }, // 522 + { "currency", CURRENCY }, // 523 + { "current", CURRENT }, // 524 + { "current-date", CURRENT_DATE }, // 525 + { "data", DATA }, // 526 + { "date", DATE }, // 527 + { "date-compiled", DATE_COMPILED }, // 528 + { "date-of-integer", DATE_OF_INTEGER }, // 529 + { "date-to-yyyymmdd", DATE_TO_YYYYMMDD }, // 530 + { "date-written", DATE_WRITTEN }, // 531 + { "day", DAY }, // 532 + { "day-of-integer", DAY_OF_INTEGER }, // 533 + { "day-of-week", DAY_OF_WEEK }, // 534 + { "day-to-yyyyddd", DAY_TO_YYYYDDD }, // 535 + { "dbcs", DBCS }, // 536 + { "de", DE }, // 537 + { "debugging", DEBUGGING }, // 538 + { "decimal-point", DECIMAL_POINT }, // 539 + { "declaratives", DECLARATIVES }, // 540 + { "delimited", DELIMITED }, // 541 + { "delimiter", DELIMITER }, // 542 + { "depending", DEPENDING }, // 543 + { "descending", DESCENDING }, // 544 + { "detail", DETAIL }, // 545 + { "direct", DIRECT }, // 546 + { "direct-access", DIRECT_ACCESS }, // 547 + { "down", DOWN }, // 548 + { "duplicates", DUPLICATES }, // 549 + { "dynamic", DYNAMIC }, // 550 + { "e", E }, // 551 + { "ebcdic", EBCDIC }, // 552 + { "ec", EC }, // 553 + { "egcs", EGCS }, // 554 + { "encoding", ENCODING }, // 555 + { "entry", ENTRY }, // 556 + { "environment", ENVIRONMENT }, // 557 + { "every", EVERY }, // 558 + { "examine", EXAMINE }, // 559 + { "exhibit", EXHIBIT }, // 560 + { "exp", EXP }, // 561 + { "exp10", EXP10 }, // 562 + { "extend", EXTEND }, // 563 + { "external", EXTERNAL }, // 564 + { "exception-file", EXCEPTION_FILE }, // 565 + { "exception-file-n", EXCEPTION_FILE_N }, // 566 + { "exception-location", EXCEPTION_LOCATION }, // 567 + { "exception-location-n", EXCEPTION_LOCATION_N }, // 568 + { "exception-statement", EXCEPTION_STATEMENT }, // 569 + { "exception-status", EXCEPTION_STATUS }, // 570 + { "factorial", FACTORIAL }, // 571 + { "false", FALSE_kw }, // 572 + { "fd", FD }, // 573 + { "file-control", FILE_CONTROL }, // 574 + { "file", FILE_KW }, // 575 + { "file-limit", FILE_LIMIT }, // 576 + { "final", FINAL }, // 577 + { "finally", FINALLY }, // 578 + { "find-string", FIND_STRING }, // 579 + { "first", FIRST }, // 580 + { "fixed", FIXED }, // 581 + { "footing", FOOTING }, // 582 + { "for", FOR }, // 583 + { "formatted-current-date", FORMATTED_CURRENT_DATE }, // 584 + { "formatted-date", FORMATTED_DATE }, // 585 + { "formatted-datetime", FORMATTED_DATETIME }, // 586 + { "formatted-time", FORMATTED_TIME }, // 587 + { "form-overflow", FORM_OVERFLOW }, // 588 + { "free", FREE }, // 589 + { "fraction-part", FRACTION_PART }, // 590 + { "from", FROM }, // 591 + { "function", FUNCTION }, // 592 + { "generate", GENERATE }, // 593 + { "giving", GIVING }, // 594 + { "global", GLOBAL }, // 595 + { "go", GO }, // 596 + { "group", GROUP }, // 597 + { "heading", HEADING }, // 598 + { "hex", HEX }, // 599 + { "hex-of", HEX_OF }, // 600 + { "hex-to-char", HEX_TO_CHAR }, // 601 + { "high-values", HIGH_VALUES }, // 602 + { "highest-algebraic", HIGHEST_ALGEBRAIC }, // 603 + { "hold", HOLD }, // 604 + { "ibm-360", IBM_360 }, // 605 + { "in", IN }, // 606 + { "include", INCLUDE }, // 607 + { "index", INDEX }, // 608 + { "indexed", INDEXED }, // 609 + { "indicate", INDICATE }, // 610 + { "initial", INITIAL_kw }, // 611 + { "initiate", INITIATE }, // 612 + { "input", INPUT }, // 613 + { "installation", INSTALLATION }, // 614 + { "interface", INTERFACE }, // 615 + { "integer", INTEGER }, // 616 + { "integer-of-boolean", INTEGER_OF_BOOLEAN }, // 617 + { "integer-of-date", INTEGER_OF_DATE }, // 618 + { "integer-of-day", INTEGER_OF_DAY }, // 619 + { "integer-of-formatted-date", INTEGER_OF_FORMATTED_DATE }, // 620 + { "integer-part", INTEGER_PART }, // 621 + { "into", INTO }, // 622 + { "intrinsic", INTRINSIC }, // 623 + { "invoke", INVOKE }, // 624 + { "i-o", IO }, // 625 + { "i-o-control", IO_CONTROL }, // 626 + { "is", IS }, // 627 + { "isnt", ISNT }, // 628 + { "kanji", KANJI }, // 629 + { "key", KEY }, // 630 + { "label", LABEL }, // 631 + { "last", LAST }, // 632 + { "leading", LEADING }, // 633 + { "left", LEFT }, // 634 + { "length", LENGTH }, // 635 + { "length-of", LENGTH_OF }, // 636 + { "limit", LIMIT }, // 637 + { "limits", LIMITS }, // 638 + { "line", LINE }, // 639 + { "lines", LINES }, // 640 + { "line-counter", LINE_COUNTER }, // 641 + { "linage", LINAGE }, // 642 + { "linkage", LINKAGE }, // 643 + { "locale", LOCALE }, // 644 + { "locale-compare", LOCALE_COMPARE }, // 645 + { "locale-date", LOCALE_DATE }, // 646 + { "locale-time", LOCALE_TIME }, // 647 + { "locale-time-from-seconds", LOCALE_TIME_FROM_SECONDS }, // 648 + { "local-storage", LOCAL_STORAGE }, // 649 + { "location", LOCATION }, // 650 + { "lock", LOCK }, // 651 + { "lock-on", LOCK_ON }, // 652 + { "log", LOG }, // 653 + { "log10", LOG10 }, // 654 + { "lower-case", LOWER_CASE }, // 655 + { "low-values", LOW_VALUES }, // 656 + { "lowest-algebraic", LOWEST_ALGEBRAIC }, // 657 + { "lparen", LPAREN }, // 658 + { "manual", MANUAL }, // 659 + { "maxx", MAXX }, // 660 + { "mean", MEAN }, // 661 + { "median", MEDIAN }, // 662 + { "midrange", MIDRANGE }, // 663 + { "minn", MINN }, // 664 + { "multiple", MULTIPLE }, // 665 + { "mod", MOD }, // 666 + { "mode", MODE }, // 667 + { "module-name", MODULE_NAME }, // 668 + { "named", NAMED }, // 669 + { "nat", NAT }, // 670 + { "national", NATIONAL }, // 671 + { "national-edited", NATIONAL_EDITED }, // 672 + { "national-of", NATIONAL_OF }, // 673 + { "native", NATIVE }, // 674 + { "nested", NESTED }, // 675 + { "next", NEXT }, // 676 + { "no", NO }, // 677 + { "note", NOTE }, // 678 + { "nulls", NULLS }, // 679 + { "null", NULLS }, // 679 + { "nullptr", NULLPTR }, // 680 + { "numeric", NUMERIC }, // 681 + { "numeric-edited", NUMERIC_EDITED }, // 682 + { "numval", NUMVAL }, // 683 + { "numval-c", NUMVAL_C }, // 684 + { "numval-f", NUMVAL_F }, // 685 + { "occurs", OCCURS }, // 686 + { "of", OF }, // 687 + { "off", OFF }, // 688 + { "omitted", OMITTED }, // 689 + { "on", ON }, // 690 + { "only", ONLY }, // 691 + { "optional", OPTIONAL }, // 692 + { "options", OPTIONS }, // 693 + { "ord", ORD }, // 694 + { "order", ORDER }, // 695 + { "ord-max", ORD_MAX }, // 696 + { "ord-min", ORD_MIN }, // 697 + { "organization", ORGANIZATION }, // 698 + { "other", OTHER }, // 699 + { "otherwise", OTHERWISE }, // 700 + { "output", OUTPUT }, // 701 + { "packed-decimal", PACKED_DECIMAL }, // 702 + { "padding", PADDING }, // 703 + { "page", PAGE }, // 704 + { "page-counter", PAGE_COUNTER }, // 705 + { "pf", PF }, // 706 + { "ph", PH }, // 707 + { "pi", PI }, // 708 + { "pic", PIC }, // 709 + { "picture", PICTURE }, // 710 + { "plus", PLUS }, // 711 + { "present-value", PRESENT_VALUE }, // 712 + { "print-switch", PRINT_SWITCH }, // 713 + { "procedure", PROCEDURE }, // 714 + { "procedures", PROCEDURES }, // 715 + { "proceed", PROCEED }, // 716 + { "process", PROCESS }, // 717 + { "processing", PROCESSING }, // 718 + { "program-id", PROGRAM_ID }, // 719 + { "program", PROGRAM_kw }, // 720 + { "property", PROPERTY }, // 721 + { "prototype", PROTOTYPE }, // 722 + { "pseudotext", PSEUDOTEXT }, // 723 + { "quotes", QUOTES }, // 724 + { "quote", QUOTES }, // 724 + { "random", RANDOM }, // 725 + { "random-seed", RANDOM_SEED }, // 726 + { "range", RANGE }, // 727 + { "raise", RAISE }, // 728 + { "raising", RAISING }, // 729 + { "rd", RD }, // 730 + { "record", RECORD }, // 731 + { "recording", RECORDING }, // 732 + { "records", RECORDS }, // 733 + { "recursive", RECURSIVE }, // 734 + { "redefines", REDEFINES }, // 735 + { "reel", REEL }, // 736 + { "reference", REFERENCE }, // 737 + { "relative", RELATIVE }, // 738 + { "rem", REM }, // 739 + { "remainder", REMAINDER }, // 740 + { "remarks", REMARKS }, // 741 + { "removal", REMOVAL }, // 742 + { "renames", RENAMES }, // 743 + { "replace", REPLACE }, // 744 + { "replacing", REPLACING }, // 745 + { "report", REPORT }, // 746 + { "reporting", REPORTING }, // 747 + { "reports", REPORTS }, // 748 + { "repository", REPOSITORY }, // 749 + { "rerun", RERUN }, // 750 + { "reserve", RESERVE }, // 751 + { "restricted", RESTRICTED }, // 752 + { "resume", RESUME }, // 753 + { "retry", RETRY }, // 754 + { "reverse", REVERSE }, // 755 + { "reversed", REVERSED }, // 756 + { "rewind", REWIND }, // 757 + { "rf", RF }, // 758 + { "rh", RH }, // 759 + { "right", RIGHT }, // 760 + { "rounded", ROUNDED }, // 761 + { "run", RUN }, // 762 + { "same", SAME }, // 763 + { "screen", SCREEN }, // 764 + { "sd", SD }, // 765 + { "seconds-from-formatted-time", SECONDS_FROM_FORMATTED_TIME }, // 766 + { "seconds-past-midnight", SECONDS_PAST_MIDNIGHT }, // 767 + { "security", SECURITY }, // 768 + { "separate", SEPARATE }, // 769 + { "sequence", SEQUENCE }, // 770 + { "sequential", SEQUENTIAL }, // 771 + { "sharing", SHARING }, // 772 + { "simple-exit", SIMPLE_EXIT }, // 773 + { "sign", SIGN }, // 774 + { "sin", SIN }, // 775 + { "size", SIZE }, // 776 + { "smallest-algebraic", SMALLEST_ALGEBRAIC }, // 777 + { "source", SOURCE }, // 778 + { "source-computer", SOURCE_COMPUTER }, // 779 + { "special-names", SPECIAL_NAMES }, // 780 + { "sqrt", SQRT }, // 781 + { "stack", STACK }, // 782 + { "standard", STANDARD }, // 783 + { "standard-1", STANDARD_1 }, // 784 + { "standard-deviation", STANDARD_DEVIATION }, // 785 + { "standard-compare", STANDARD_COMPARE }, // 786 + { "status", STATUS }, // 787 + { "strong", STRONG }, // 788 + { "substitute", SUBSTITUTE }, // 789 + { "sum", SUM }, // 790 + { "symbol", SYMBOL }, // 791 + { "symbolic", SYMBOLIC }, // 792 + { "synchronized", SYNCHRONIZED }, // 793 + { "tallying", TALLYING }, // 794 + { "tan", TAN }, // 795 + { "terminate", TERMINATE }, // 796 + { "test", TEST }, // 797 + { "test-date-yyyymmdd", TEST_DATE_YYYYMMDD }, // 798 + { "test-day-yyyyddd", TEST_DAY_YYYYDDD }, // 799 + { "test-formatted-datetime", TEST_FORMATTED_DATETIME }, // 800 + { "test-numval", TEST_NUMVAL }, // 801 + { "test-numval-c", TEST_NUMVAL_C }, // 802 + { "test-numval-f", TEST_NUMVAL_F }, // 803 + { "than", THAN }, // 804 + { "time", TIME }, // 805 + { "times", TIMES }, // 806 + { "to", TO }, // 807 + { "top", TOP }, // 808 + { "top-level", TOP_LEVEL }, // 809 + { "tracks", TRACKS }, // 810 + { "track-area", TRACK_AREA }, // 811 + { "trailing", TRAILING }, // 812 + { "transform", TRANSFORM }, // 813 + { "trim", TRIM }, // 814 + { "true", TRUE_kw }, // 815 + { "try", TRY }, // 816 + { "turn", TURN }, // 817 + { "type", TYPE }, // 818 + { "typedef", TYPEDEF }, // 819 + { "ulength", ULENGTH }, // 820 + { "unbounded", UNBOUNDED }, // 821 + { "unit", UNIT }, // 822 + { "units", UNITS }, // 823 + { "unit-record", UNIT_RECORD }, // 824 + { "until", UNTIL }, // 825 + { "up", UP }, // 826 + { "upon", UPON }, // 827 + { "upos", UPOS }, // 828 + { "upper-case", UPPER_CASE }, // 829 + { "usage", USAGE }, // 830 + { "using", USING }, // 831 + { "usubstr", USUBSTR }, // 832 + { "usupplementary", USUPPLEMENTARY }, // 833 + { "utility", UTILITY }, // 834 + { "uuid4", UUID4 }, // 835 + { "uvalid", UVALID }, // 836 + { "uwidth", UWIDTH }, // 837 + { "validating", VALIDATING }, // 838 + { "value", VALUE }, // 839 + { "variance", VARIANCE }, // 840 + { "varying", VARYING }, // 841 + { "volatile", VOLATILE }, // 842 + { "when-compiled", WHEN_COMPILED }, // 843 + { "with", WITH }, // 844 + { "working-storage", WORKING_STORAGE }, // 845 + { "year-to-yyyy", YEAR_TO_YYYY }, // 846 + { "yyyyddd", YYYYDDD }, // 847 + { "yyyymmdd", YYYYMMDD }, // 848 + { "arithmetic", ARITHMETIC }, // 849 + { "attribute", ATTRIBUTE }, // 850 + { "auto", AUTO }, // 851 + { "automatic", AUTOMATIC }, // 852 + { "away-from-zero", AWAY_FROM_ZERO }, // 853 + { "background-color", BACKGROUND_COLOR }, // 854 + { "bell", BELL }, // 855 + { "binary-encoding", BINARY_ENCODING }, // 856 + { "blink", BLINK }, // 857 + { "capacity", CAPACITY }, // 858 + { "center", CENTER }, // 859 + { "classification", CLASSIFICATION }, // 860 + { "cycle", CYCLE }, // 861 + { "decimal-encoding", DECIMAL_ENCODING }, // 862 + { "entry-convention", ENTRY_CONVENTION }, // 863 + { "eol", EOL }, // 864 + { "eos", EOS }, // 865 + { "erase", ERASE }, // 866 + { "expands", EXPANDS }, // 867 + { "float-binary", FLOAT_BINARY }, // 868 + { "float-decimal", FLOAT_DECIMAL }, // 869 + { "foreground-color", FOREGROUND_COLOR }, // 870 + { "forever", FOREVER }, // 871 + { "full", FULL }, // 872 + { "highlight", HIGHLIGHT }, // 873 + { "high-order-left", HIGH_ORDER_LEFT }, // 874 + { "high-order-right", HIGH_ORDER_RIGHT }, // 875 + { "ignoring", IGNORING }, // 876 + { "implements", IMPLEMENTS }, // 877 + { "initialized", INITIALIZED }, // 878 + { "intermediate", INTERMEDIATE }, // 879 + { "lc-all", LC_ALL_kw }, // 880 + { "lc-collate", LC_COLLATE_kw }, // 881 + { "lc-ctype", LC_CTYPE_kw }, // 882 + { "lc-messages", LC_MESSAGES_kw }, // 883 + { "lc-monetary", LC_MONETARY_kw }, // 884 + { "lc-numeric", LC_NUMERIC_kw }, // 885 + { "lc-time", LC_TIME_kw }, // 886 + { "lowlight", LOWLIGHT }, // 887 + { "nearest-away-from-zero", NEAREST_AWAY_FROM_ZERO }, // 888 + { "nearest-even", NEAREST_EVEN }, // 889 + { "nearest-toward-zero", NEAREST_TOWARD_ZERO }, // 890 + { "none", NONE }, // 891 + { "normal", NORMAL }, // 892 + { "numbers", NUMBERS }, // 893 + { "prefixed", PREFIXED }, // 894 + { "previous", PREVIOUS }, // 895 + { "prohibited", PROHIBITED }, // 896 + { "relation", RELATION }, // 897 + { "required", REQUIRED }, // 898 + { "reverse-video", REVERSE_VIDEO }, // 899 + { "rounding", ROUNDING }, // 900 + { "seconds", SECONDS }, // 901 + { "secure", SECURE }, // 902 + { "short", SHORT }, // 903 + { "signed", SIGNED_kw }, // 904 + { "standard-binary", STANDARD_BINARY }, // 905 + { "standard-decimal", STANDARD_DECIMAL }, // 906 + { "statement", STATEMENT }, // 907 + { "step", STEP }, // 908 + { "structure", STRUCTURE }, // 909 + { "toward-greater", TOWARD_GREATER }, // 910 + { "toward-lesser", TOWARD_LESSER }, // 911 + { "truncation", TRUNCATION }, // 912 + { "ucs-4", UCS_4 }, // 913 + { "underline", UNDERLINE }, // 914 + { "unsigned", UNSIGNED_kw }, // 915 + { "utf-16", UTF_16 }, // 916 + { "utf-8", UTF_8 }, // 917 + { "xmlgenerate", XMLGENERATE }, // 918 + { "xmlparse", XMLPARSE }, // 919 + { "address", ADDRESS }, // 920 + { "end-accept", END_ACCEPT }, // 921 + { "end-add", END_ADD }, // 922 + { "end-call", END_CALL }, // 923 + { "end-compute", END_COMPUTE }, // 924 + { "end-delete", END_DELETE }, // 925 + { "end-display", END_DISPLAY }, // 926 + { "end-divide", END_DIVIDE }, // 927 + { "end-evaluate", END_EVALUATE }, // 928 + { "end-multiply", END_MULTIPLY }, // 929 + { "end-perform", END_PERFORM }, // 930 + { "end-read", END_READ }, // 931 + { "end-return", END_RETURN }, // 932 + { "end-rewrite", END_REWRITE }, // 933 + { "end-search", END_SEARCH }, // 934 + { "end-start", END_START }, // 935 + { "end-string", END_STRING }, // 936 + { "end-subtract", END_SUBTRACT }, // 937 + { "end-unstring", END_UNSTRING }, // 938 + { "end-write", END_WRITE }, // 939 + { "end-xml", END_XML }, // 940 + { "end-if", END_IF }, // 941 + { "attributes", ATTRIBUTES }, // 942 + { "element", ELEMENT }, // 943 + { "namespace", NAMESPACE }, // 944 + { "namespace-prefix", NAMESPACE_PREFIX }, // 945 + { "nonnumeric", NONNUMERIC }, // 947 + { "xml-declaration", XML_DECLARATION }, // 948 + { "thru", THRU }, // 950 + { "through", THRU }, // 950 + { "or", OR }, // 951 + { "and", AND }, // 952 + { "not", NOT }, // 953 + { "ne", NE }, // 954 + { "le", LE }, // 955 + { "ge", GE }, // 956 + { "pow", POW }, // 957 + { "neg", NEG }, // 958 }; +// 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) + "EQ", // 40 (298) + "LITERAL", // 41 (299) + "END", // 42 (300) + "EOP", // 43 (301) + "FILENAME", // 44 (302) + "INVALID", // 45 (303) + "NUMBER", // 46 (304) + "NEGATIVE", // 47 (305) + "NUMSTR", // 48 (306) + "OVERFLOW", // 49 (307) + "BINARY-INTEGER", // 50 (308) + "COMPUTATIONAL", // 51 (309) + "PERFORM", // 52 (310) + "BACKWARD", // 53 (311) + "POSITIVE", // 54 (312) + "POINTER", // 55 (313) + "SECTION", // 56 (314) + "STANDARD-ALPHABET", // 57 (315) + "SWITCH", // 58 (316) + "UPSI", // 59 (317) + "ZERO", // 60 (318) + "SYSIN", // 61 (319) + "SYSIPT", // 62 (320) + "SYSOUT", // 63 (321) + "SYSLIST", // 64 (322) + "SYSLST", // 65 (323) + "SYSPUNCH", // 66 (324) + "SYSPCH", // 67 (325) + "CONSOLE", // 68 (326) + "C01", // 69 (327) + "C02", // 70 (328) + "C03", // 71 (329) + "C04", // 72 (330) + "C05", // 73 (331) + "C06", // 74 (332) + "C07", // 75 (333) + "C08", // 76 (334) + "C09", // 77 (335) + "C10", // 78 (336) + "C11", // 79 (337) + "C12", // 80 (338) + "CSP", // 81 (339) + "S01", // 82 (340) + "S02", // 83 (341) + "S03", // 84 (342) + "S04", // 85 (343) + "S05", // 86 (344) + "AFP-5A", // 87 (345) + "STDIN", // 88 (346) + "STDOUT", // 89 (347) + "STDERR", // 90 (348) + "LIST", // 91 (349) + "MAP", // 92 (350) + "NOLIST", // 93 (351) + "NOMAP", // 94 (352) + "NOSOURCE", // 95 (353) + "MIGHT-BE", // 96 (354) + "FUNCTION-UDF", // 97 (355) + "FUNCTION-UDF-0", // 98 (356) + "DEFAULT", // 99 (357) + "DATE-FMT", // 100 (358) + "TIME-FMT", // 101 (359) + "DATETIME-FMT", // 102 (360) + "BASIS", // 103 (361) + "CBL", // 104 (362) + "CONSTANT", // 105 (363) + "COPY", // 106 (364) + "DEFINED", // 107 (365) + "ENTER", // 108 (366) + "FEATURE", // 109 (367) + "INSERTT", // 110 (368) + "LSUB", // 111 (369) + "PARAMETER", // 112 (370) + "OVERRIDE", // 113 (371) + "READY", // 114 (372) + "RESET", // 115 (373) + "RSUB", // 116 (374) + "SERVICE-RELOAD", // 117 (375) + "STAR-CBL", // 118 (376) + "SUBSCRIPT", // 119 (377) + "SUPPRESS", // 120 (378) + "TITLE", // 121 (379) + "TRACE", // 122 (380) + "USE", // 123 (381) + "COBOL-WORDS", // 124 (382) + "EQUATE", // 125 (383) + "UNDEFINE", // 126 (384) + "CDF-DEFINE", // 127 (385) + "CDF-DISPLAY", // 128 (386) + "CDF-IF", // 129 (387) + "CDF-ELSE", // 130 (388) + "CDF-END-IF", // 131 (389) + "CDF-EVALUATE", // 132 (390) + "CDF-WHEN", // 133 (391) + "CDF-END-EVALUATE", // 134 (392) + "CALL-CONVENTION", // 135 (393) + "CALL-COBOL", // 136 (394) + "CALL-VERBATIM", // 137 (395) + "CDF-PUSH", // 138 (396) + "CDF-POP", // 139 (397) + "SOURCE-FORMAT", // 140 (398) + "IF", // 141 (399) + "THEN", // 142 (400) + "ELSE", // 143 (401) + "SENTENCE", // 144 (402) + "ACCEPT", // 145 (403) + "ADD", // 146 (404) + "ALTER", // 147 (405) + "CALL", // 148 (406) + "CANCEL", // 149 (407) + "CLOSE", // 150 (408) + "COMPUTE", // 151 (409) + "CONTINUE", // 152 (410) + "DELETE", // 153 (411) + "DISPLAY", // 154 (412) + "DIVIDE", // 155 (413) + "EVALUATE", // 156 (414) + "EXIT", // 157 (415) + "FILLER", // 158 (416) + "GOBACK", // 159 (417) + "GOTO", // 160 (418) + "INITIALIZE", // 161 (419) + "INSPECT", // 162 (420) + "MERGE", // 163 (421) + "MOVE", // 164 (422) + "MULTIPLY", // 165 (423) + "OPEN", // 166 (424) + "PARAGRAPH", // 167 (425) + "READ", // 168 (426) + "RELEASE", // 169 (427) + "RETURN", // 170 (428) + "REWRITE", // 171 (429) + "SEARCH", // 172 (430) + "SET", // 173 (431) + "SELECT", // 174 (432) + "SORT", // 175 (433) + "SORT-MERGE", // 176 (434) + "STRING", // 177 (435) + "STOP", // 178 (436) + "SUBTRACT", // 179 (437) + "START", // 180 (438) + "UNSTRING", // 181 (439) + "WRITE", // 182 (440) + "WHEN", // 183 (441) + "ARGUMENT-NUMBER", // 184 (442) + "ARGUMENT-VALUE", // 185 (443) + "ENVIRONMENT-NAME", // 186 (444) + "ENVIRONMENT-VALUE", // 187 (445) + "ABS", // 188 (446) + "ACCESS", // 189 (447) + "ACOS", // 190 (448) + "ACTUAL", // 191 (449) + "ADVANCING", // 192 (450) + "AFTER", // 193 (451) + "ALL", // 194 (452) + "ALLOCATE", // 195 (453) + "ALPHABET", // 196 (454) + "ALPHABETIC", // 197 (455) + "ALPHABETIC-LOWER", // 198 (456) + "ALPHABETIC-UPPER", // 199 (457) + "ALPHANUMERIC", // 200 (458) + "ALPHANUMERIC-EDITED", // 201 (459) + "ALSO", // 202 (460) + "ALTERNATE", // 203 (461) + "ANNUITY", // 204 (462) + "ANUM", // 205 (463) + "ANY", // 206 (464) + "ANYCASE", // 207 (465) + "APPLY", // 208 (466) + "ARE", // 209 (467) + "AREA", // 210 (468) + "AREAS", // 211 (469) + "AS", // 212 (470) + "ASCENDING", // 213 (471) + "ACTIVATING", // 214 (472) + "ASIN", // 215 (473) + "ASSIGN", // 216 (474) + "AT", // 217 (475) + "ATAN", // 218 (476) + "BASED", // 219 (477) + "BASECONVERT", // 220 (478) + "BEFORE", // 221 (479) + "BINARY", // 222 (480) + "BIT", // 223 (481) + "BIT-OF", // 224 (482) + "BIT-TO-CHAR", // 225 (483) + "BLANK", // 226 (484) + "BLOCK", // 227 (485) + "BOOLEAN-OF-INTEGER", // 228 (486) + "BOTTOM", // 229 (487) + "BY", // 230 (488) + "BYTE", // 231 (489) + "BYTE-LENGTH", // 232 (490) + "CF", // 233 (491) + "CH", // 234 (492) + "CHANGED", // 235 (493) + "CHAR", // 236 (494) + "CHAR-NATIONAL", // 237 (495) + "CHARACTER", // 238 (496) + "CHARACTERS", // 239 (497) + "CHECKING", // 240 (498) + "CLASS", // 241 (499) + "COBOL", // 242 (500) + "CODE", // 243 (501) + "CODE-SET", // 244 (502) + "COLLATING", // 245 (503) + "COLUMN", // 246 (504) + "COMBINED-DATETIME", // 247 (505) + "COMMA", // 248 (506) + "COMMAND-LINE", // 249 (507) + "COMMAND-LINE-COUNT", // 250 (508) + "COMMIT", // 251 (509) + "COMMON", // 252 (510) + "CONCAT", // 253 (511) + "CONDITION", // 254 (512) + "CONFIGURATION", // 255 (513) + "CONTAINS", // 256 (514) + "CONTENT", // 257 (515) + "CONTROL", // 258 (516) + "CONTROLS", // 259 (517) + "CONVERT", // 260 (518) + "CONVERTING", // 261 (519) + "CORRESPONDING", // 262 (520) + "COS", // 263 (521) + "COUNT", // 264 (522) + "CURRENCY", // 265 (523) + "CURRENT", // 266 (524) + "CURRENT-DATE", // 267 (525) + "DATA", // 268 (526) + "DATE", // 269 (527) + "DATE-COMPILED", // 270 (528) + "DATE-OF-INTEGER", // 271 (529) + "DATE-TO-YYYYMMDD", // 272 (530) + "DATE-WRITTEN", // 273 (531) + "DAY", // 274 (532) + "DAY-OF-INTEGER", // 275 (533) + "DAY-OF-WEEK", // 276 (534) + "DAY-TO-YYYYDDD", // 277 (535) + "DBCS", // 278 (536) + "DE", // 279 (537) + "DEBUGGING", // 280 (538) + "DECIMAL-POINT", // 281 (539) + "DECLARATIVES", // 282 (540) + "DELIMITED", // 283 (541) + "DELIMITER", // 284 (542) + "DEPENDING", // 285 (543) + "DESCENDING", // 286 (544) + "DETAIL", // 287 (545) + "DIRECT", // 288 (546) + "DIRECT-ACCESS", // 289 (547) + "DOWN", // 290 (548) + "DUPLICATES", // 291 (549) + "DYNAMIC", // 292 (550) + "E", // 293 (551) + "EBCDIC", // 294 (552) + "EC", // 295 (553) + "EGCS", // 296 (554) + "ENCODING", // 297 (555) + "ENTRY", // 298 (556) + "ENVIRONMENT", // 299 (557) + "EVERY", // 300 (558) + "EXAMINE", // 301 (559) + "EXHIBIT", // 302 (560) + "EXP", // 303 (561) + "EXP10", // 304 (562) + "EXTEND", // 305 (563) + "EXTERNAL", // 306 (564) + "EXCEPTION-FILE", // 307 (565) + "EXCEPTION-FILE-N", // 308 (566) + "EXCEPTION-LOCATION", // 309 (567) + "EXCEPTION-LOCATION-N", // 310 (568) + "EXCEPTION-STATEMENT", // 311 (569) + "EXCEPTION-STATUS", // 312 (570) + "FACTORIAL", // 313 (571) + "FALSE", // 314 (572) + "FD", // 315 (573) + "FILE-CONTROL", // 316 (574) + "FILE", // 317 (575) + "FILE-LIMIT", // 318 (576) + "FINAL", // 319 (577) + "FINALLY", // 320 (578) + "FIND-STRING", // 321 (579) + "FIRST", // 322 (580) + "FIXED", // 323 (581) + "FOOTING", // 324 (582) + "FOR", // 325 (583) + "FORMATTED-CURRENT-DATE", // 326 (584) + "FORMATTED-DATE", // 327 (585) + "FORMATTED-DATETIME", // 328 (586) + "FORMATTED-TIME", // 329 (587) + "FORM-OVERFLOW", // 330 (588) + "FREE", // 331 (589) + "FRACTION-PART", // 332 (590) + "FROM", // 333 (591) + "FUNCTION", // 334 (592) + "GENERATE", // 335 (593) + "GIVING", // 336 (594) + "GLOBAL", // 337 (595) + "GO", // 338 (596) + "GROUP", // 339 (597) + "HEADING", // 340 (598) + "HEX", // 341 (599) + "HEX-OF", // 342 (600) + "HEX-TO-CHAR", // 343 (601) + "HIGH-VALUES", // 344 (602) + "HIGHEST-ALGEBRAIC", // 345 (603) + "HOLD", // 346 (604) + "IBM-360", // 347 (605) + "IN", // 348 (606) + "INCLUDE", // 349 (607) + "INDEX", // 350 (608) + "INDEXED", // 351 (609) + "INDICATE", // 352 (610) + "INITIAL", // 353 (611) + "INITIATE", // 354 (612) + "INPUT", // 355 (613) + "INSTALLATION", // 356 (614) + "INTERFACE", // 357 (615) + "INTEGER", // 358 (616) + "INTEGER-OF-BOOLEAN", // 359 (617) + "INTEGER-OF-DATE", // 360 (618) + "INTEGER-OF-DAY", // 361 (619) + "INTEGER-OF-FORMATTED-DATE", // 362 (620) + "INTEGER-PART", // 363 (621) + "INTO", // 364 (622) + "INTRINSIC", // 365 (623) + "INVOKE", // 366 (624) + "I-O", // 367 (625) + "I-O-CONTROL", // 368 (626) + "IS", // 369 (627) + "ISNT", // 370 (628) + "KANJI", // 371 (629) + "KEY", // 372 (630) + "LABEL", // 373 (631) + "LAST", // 374 (632) + "LEADING", // 375 (633) + "LEFT", // 376 (634) + "LENGTH", // 377 (635) + "LENGTH-OF", // 378 (636) + "LIMIT", // 379 (637) + "LIMITS", // 380 (638) + "LINE", // 381 (639) + "LINES", // 382 (640) + "LINE-COUNTER", // 383 (641) + "LINAGE", // 384 (642) + "LINKAGE", // 385 (643) + "LOCALE", // 386 (644) + "LOCALE-COMPARE", // 387 (645) + "LOCALE-DATE", // 388 (646) + "LOCALE-TIME", // 389 (647) + "LOCALE-TIME-FROM-SECONDS", // 390 (648) + "LOCAL-STORAGE", // 391 (649) + "LOCATION", // 392 (650) + "LOCK", // 393 (651) + "LOCK-ON", // 394 (652) + "LOG", // 395 (653) + "LOG10", // 396 (654) + "LOWER-CASE", // 397 (655) + "LOW-VALUES", // 398 (656) + "LOWEST-ALGEBRAIC", // 399 (657) + "LPAREN", // 400 (658) + "MANUAL", // 401 (659) + "MAXX", // 402 (660) + "MEAN", // 403 (661) + "MEDIAN", // 404 (662) + "MIDRANGE", // 405 (663) + "MINN", // 406 (664) + "MULTIPLE", // 407 (665) + "MOD", // 408 (666) + "MODE", // 409 (667) + "MODULE-NAME", // 410 (668) + "NAMED", // 411 (669) + "NAT", // 412 (670) + "NATIONAL", // 413 (671) + "NATIONAL-EDITED", // 414 (672) + "NATIONAL-OF", // 415 (673) + "NATIVE", // 416 (674) + "NESTED", // 417 (675) + "NEXT", // 418 (676) + "NO", // 419 (677) + "NOTE", // 420 (678) + "NULLS", // 421 (679) + "NULLPTR", // 422 (680) + "NUMERIC", // 423 (681) + "NUMERIC-EDITED", // 424 (682) + "NUMVAL", // 425 (683) + "NUMVAL-C", // 426 (684) + "NUMVAL-F", // 427 (685) + "OCCURS", // 428 (686) + "OF", // 429 (687) + "OFF", // 430 (688) + "OMITTED", // 431 (689) + "ON", // 432 (690) + "ONLY", // 433 (691) + "OPTIONAL", // 434 (692) + "OPTIONS", // 435 (693) + "ORD", // 436 (694) + "ORDER", // 437 (695) + "ORD-MAX", // 438 (696) + "ORD-MIN", // 439 (697) + "ORGANIZATION", // 440 (698) + "OTHER", // 441 (699) + "OTHERWISE", // 442 (700) + "OUTPUT", // 443 (701) + "PACKED-DECIMAL", // 444 (702) + "PADDING", // 445 (703) + "PAGE", // 446 (704) + "PAGE-COUNTER", // 447 (705) + "PF", // 448 (706) + "PH", // 449 (707) + "PI", // 450 (708) + "PIC", // 451 (709) + "PICTURE", // 452 (710) + "PLUS", // 453 (711) + "PRESENT-VALUE", // 454 (712) + "PRINT-SWITCH", // 455 (713) + "PROCEDURE", // 456 (714) + "PROCEDURES", // 457 (715) + "PROCEED", // 458 (716) + "PROCESS", // 459 (717) + "PROCESSING", // 460 (718) + "PROGRAM-ID", // 461 (719) + "PROGRAM", // 462 (720) + "PROPERTY", // 463 (721) + "PROTOTYPE", // 464 (722) + "PSEUDOTEXT", // 465 (723) + "QUOTES", // 466 (724) + "RANDOM", // 467 (725) + "RANDOM-SEED", // 468 (726) + "RANGE", // 469 (727) + "RAISE", // 470 (728) + "RAISING", // 471 (729) + "RD", // 472 (730) + "RECORD", // 473 (731) + "RECORDING", // 474 (732) + "RECORDS", // 475 (733) + "RECURSIVE", // 476 (734) + "REDEFINES", // 477 (735) + "REEL", // 478 (736) + "REFERENCE", // 479 (737) + "RELATIVE", // 480 (738) + "REM", // 481 (739) + "REMAINDER", // 482 (740) + "REMARKS", // 483 (741) + "REMOVAL", // 484 (742) + "RENAMES", // 485 (743) + "REPLACE", // 486 (744) + "REPLACING", // 487 (745) + "REPORT", // 488 (746) + "REPORTING", // 489 (747) + "REPORTS", // 490 (748) + "REPOSITORY", // 491 (749) + "RERUN", // 492 (750) + "RESERVE", // 493 (751) + "RESTRICTED", // 494 (752) + "RESUME", // 495 (753) + "RETRY", // 496 (754) + "REVERSE", // 497 (755) + "REVERSED", // 498 (756) + "REWIND", // 499 (757) + "RF", // 500 (758) + "RH", // 501 (759) + "RIGHT", // 502 (760) + "ROUNDED", // 503 (761) + "RUN", // 504 (762) + "SAME", // 505 (763) + "SCREEN", // 506 (764) + "SD", // 507 (765) + "SECONDS-FROM-FORMATTED-TIME", // 508 (766) + "SECONDS-PAST-MIDNIGHT", // 509 (767) + "SECURITY", // 510 (768) + "SEPARATE", // 511 (769) + "SEQUENCE", // 512 (770) + "SEQUENTIAL", // 513 (771) + "SHARING", // 514 (772) + "SIMPLE-EXIT", // 515 (773) + "SIGN", // 516 (774) + "SIN", // 517 (775) + "SIZE", // 518 (776) + "SMALLEST-ALGEBRAIC", // 519 (777) + "SOURCE", // 520 (778) + "SOURCE-COMPUTER", // 521 (779) + "SPECIAL-NAMES", // 522 (780) + "SQRT", // 523 (781) + "STACK", // 524 (782) + "STANDARD", // 525 (783) + "STANDARD-1", // 526 (784) + "STANDARD-DEVIATION", // 527 (785) + "STANDARD-COMPARE", // 528 (786) + "STATUS", // 529 (787) + "STRONG", // 530 (788) + "SUBSTITUTE", // 531 (789) + "SUM", // 532 (790) + "SYMBOL", // 533 (791) + "SYMBOLIC", // 534 (792) + "SYNCHRONIZED", // 535 (793) + "TALLYING", // 536 (794) + "TAN", // 537 (795) + "TERMINATE", // 538 (796) + "TEST", // 539 (797) + "TEST-DATE-YYYYMMDD", // 540 (798) + "TEST-DAY-YYYYDDD", // 541 (799) + "TEST-FORMATTED-DATETIME", // 542 (800) + "TEST-NUMVAL", // 543 (801) + "TEST-NUMVAL-C", // 544 (802) + "TEST-NUMVAL-F", // 545 (803) + "THAN", // 546 (804) + "TIME", // 547 (805) + "TIMES", // 548 (806) + "TO", // 549 (807) + "TOP", // 550 (808) + "TOP-LEVEL", // 551 (809) + "TRACKS", // 552 (810) + "TRACK-AREA", // 553 (811) + "TRAILING", // 554 (812) + "TRANSFORM", // 555 (813) + "TRIM", // 556 (814) + "TRUE", // 557 (815) + "TRY", // 558 (816) + "TURN", // 559 (817) + "TYPE", // 560 (818) + "TYPEDEF", // 561 (819) + "ULENGTH", // 562 (820) + "UNBOUNDED", // 563 (821) + "UNIT", // 564 (822) + "UNITS", // 565 (823) + "UNIT-RECORD", // 566 (824) + "UNTIL", // 567 (825) + "UP", // 568 (826) + "UPON", // 569 (827) + "UPOS", // 570 (828) + "UPPER-CASE", // 571 (829) + "USAGE", // 572 (830) + "USING", // 573 (831) + "USUBSTR", // 574 (832) + "USUPPLEMENTARY", // 575 (833) + "UTILITY", // 576 (834) + "UUID4", // 577 (835) + "UVALID", // 578 (836) + "UWIDTH", // 579 (837) + "VALIDATING", // 580 (838) + "VALUE", // 581 (839) + "VARIANCE", // 582 (840) + "VARYING", // 583 (841) + "VOLATILE", // 584 (842) + "WHEN-COMPILED", // 585 (843) + "WITH", // 586 (844) + "WORKING-STORAGE", // 587 (845) + "YEAR-TO-YYYY", // 588 (846) + "YYYYDDD", // 589 (847) + "YYYYMMDD", // 590 (848) + "ARITHMETIC", // 591 (849) + "ATTRIBUTE", // 592 (850) + "AUTO", // 593 (851) + "AUTOMATIC", // 594 (852) + "AWAY-FROM-ZERO", // 595 (853) + "BACKGROUND-COLOR", // 596 (854) + "BELL", // 597 (855) + "BINARY-ENCODING", // 598 (856) + "BLINK", // 599 (857) + "CAPACITY", // 600 (858) + "CENTER", // 601 (859) + "CLASSIFICATION", // 602 (860) + "CYCLE", // 603 (861) + "DECIMAL-ENCODING", // 604 (862) + "ENTRY-CONVENTION", // 605 (863) + "EOL", // 606 (864) + "EOS", // 607 (865) + "ERASE", // 608 (866) + "EXPANDS", // 609 (867) + "FLOAT-BINARY", // 610 (868) + "FLOAT-DECIMAL", // 611 (869) + "FOREGROUND-COLOR", // 612 (870) + "FOREVER", // 613 (871) + "FULL", // 614 (872) + "HIGHLIGHT", // 615 (873) + "HIGH-ORDER-LEFT", // 616 (874) + "HIGH-ORDER-RIGHT", // 617 (875) + "IGNORING", // 618 (876) + "IMPLEMENTS", // 619 (877) + "INITIALIZED", // 620 (878) + "INTERMEDIATE", // 621 (879) + "LC-ALL", // 622 (880) + "LC-COLLATE", // 623 (881) + "LC-CTYPE", // 624 (882) + "LC-MESSAGES", // 625 (883) + "LC-MONETARY", // 626 (884) + "LC-NUMERIC", // 627 (885) + "LC-TIME", // 628 (886) + "LOWLIGHT", // 629 (887) + "NEAREST-AWAY-FROM-ZERO", // 630 (888) + "NEAREST-EVEN", // 631 (889) + "NEAREST-TOWARD-ZERO", // 632 (890) + "NONE", // 633 (891) + "NORMAL", // 634 (892) + "NUMBERS", // 635 (893) + "PREFIXED", // 636 (894) + "PREVIOUS", // 637 (895) + "PROHIBITED", // 638 (896) + "RELATION", // 639 (897) + "REQUIRED", // 640 (898) + "REVERSE-VIDEO", // 641 (899) + "ROUNDING", // 642 (900) + "SECONDS", // 643 (901) + "SECURE", // 644 (902) + "SHORT", // 645 (903) + "SIGNED", // 646 (904) + "STANDARD-BINARY", // 647 (905) + "STANDARD-DECIMAL", // 648 (906) + "STATEMENT", // 649 (907) + "STEP", // 650 (908) + "STRUCTURE", // 651 (909) + "TOWARD-GREATER", // 652 (910) + "TOWARD-LESSER", // 653 (911) + "TRUNCATION", // 654 (912) + "UCS-4", // 655 (913) + "UNDERLINE", // 656 (914) + "UNSIGNED", // 657 (915) + "UTF-16", // 658 (916) + "UTF-8", // 659 (917) + "XMLGENERATE", // 660 (918) + "XMLPARSE", // 661 (919) + "ADDRESS", // 662 (920) + "END-ACCEPT", // 663 (921) + "END-ADD", // 664 (922) + "END-CALL", // 665 (923) + "END-COMPUTE", // 666 (924) + "END-DELETE", // 667 (925) + "END-DISPLAY", // 668 (926) + "END-DIVIDE", // 669 (927) + "END-EVALUATE", // 670 (928) + "END-MULTIPLY", // 671 (929) + "END-PERFORM", // 672 (930) + "END-READ", // 673 (931) + "END-RETURN", // 674 (932) + "END-REWRITE", // 675 (933) + "END-SEARCH", // 676 (934) + "END-START", // 677 (935) + "END-STRING", // 678 (936) + "END-SUBTRACT", // 679 (937) + "END-UNSTRING", // 680 (938) + "END-WRITE", // 681 (939) + "END-XML", // 682 (940) + "END-IF", // 683 (941) + "ATTRIBUTES", // 684 (942) + "ELEMENT", // 685 (943) + "NAMESPACE", // 686 (944) + "NAMESPACE-PREFIX", // 687 (945) + "NONNUMERIC", // 689 (947) + "XML-DECLARATION", // 690 (948) + "THRU", // 692 (950) + "OR", // 693 (951) + "AND", // 694 (952) + "NOT", // 695 (953) + "NE", // 696 (954) + "LE", // 697 (955) + "GE", // 698 (956) + "POW", // 699 (957) + "NEG", // 700 (958) }; diff --git a/gcc/cobol/udf/stored-char-length.cbl b/gcc/cobol/udf/stored-char-length.cbl index 9ab3b14..66889d0 100644 --- a/gcc/cobol/udf/stored-char-length.cbl +++ b/gcc/cobol/udf/stored-char-length.cbl @@ -1,3 +1,6 @@ + >> PUSH source format + >>SOURCE format is fixed + * This function is in public domain. * Contributed by James K. Lowden of Cobolworx in August 2024 @@ -13,3 +16,4 @@ to Output-Value. End Function STORED-CHAR-LENGTH. + >> pop source format
\ No newline at end of file diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc index 101a0a0..32add9f 100644 --- a/gcc/cobol/util.cc +++ b/gcc/cobol/util.cc @@ -34,34 +34,34 @@ * header files. */ -#include "cobol-system.h" +#include <cobol-system.h> +#include <coretypes.h> +#include <tree.h> +#undef yy_flex_debug + #include <langinfo.h> -#include "coretypes.h" -#include "version.h" -#include "demangle.h" -#include "intl.h" -#include "backtrace.h" -#include "diagnostic.h" -#include "diagnostic-color.h" -#include "diagnostic-url.h" -#include "diagnostic-metadata.h" -#include "diagnostic-path.h" -#include "edit-context.h" -#include "selftest.h" -#include "selftest-diagnostic.h" -#include "opts.h" +#include <coretypes.h> +#include <version.h> +#include <demangle.h> +#include <intl.h> +#include <backtrace.h> +#include <diagnostic.h> +#include <opts.h> #include "util.h" + #include "cbldiag.h" +#include "cdfval.h" #include "lexio.h" -#define HOWEVER_GCC_DEFINES_TREE #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" #include "symbols.h" #include "inspect.h" #include "../../libgcobol/io.h" #include "genapi.h" +#include "genutil.h" +#include "../../libgcobol/charmaps.h" #pragma GCC diagnostic ignored "-Wunused-result" #pragma GCC diagnostic ignored "-Wmissing-field-initializers" @@ -86,25 +86,233 @@ static inline char * get_current_dir_name () { /* Use libiberty's allocator here. */ - char *buf = (char *) xmalloc (PATH_MAX); + char *buf = static_cast<char *>(xmalloc (PATH_MAX)); return getcwd (buf, PATH_MAX); } #endif +/* + * For printing messages, usually the size of the thing is some kind of string + * length, and doesn't really need a size_t. For message formatting, use a + * simple unsigned long, and warn if that's no good. "gb4" here stands for + * "4 Gigabytes". + */ +unsigned long +gb4( size_t input ) { + if( input != static_cast<unsigned long>(input) ) { + dbgmsg("size too large to print: %lx:%lx", + (unsigned long)(input >> (4 * sizeof(unsigned long))), + static_cast<unsigned long>(input)); + } + return input; +} + +/* + * Most CDF Directives -- those that have state -- can be pushed and popped. + * This class maintains stacks of them, with each stack having a "default + * value" that may be updated, without push/pop, via a CDF directive or + * command-line option. A push to a stack pushes the default value onto it; a + * pop copies the top of the stack to the default value. + * + * Supported: + * CALL-CONVENTION + * COBOL-WORDS + * DEFINE + * DISPLAY + * IF + * POP + * PUSH + * SOURCE FORMAT + * TURN + * not supported + * EVALUATE + * FLAG-02 + * FLAG-14 + * LEAP-SECOND + * LISTING + * PAGE + * PROPAGATE + * REF-MOD-ZERO-LENGTH + * + * >>PUSH ALL calls the class's push() method. + * >>POP ALL calls the class's pop() method. + */ +class cdf_directives_t +{ + template <typename T> + class cdf_stack_t : private std::stack<T> { // cppcheck-suppress noConstructor + T default_value; + const T& top() const { return std::stack<T>::top(); } + bool empty() const { return std::stack<T>::empty(); } + public: + void value( const T& value ) { + T& output( empty()? default_value : std::stack<T>::top() ); // cppcheck-suppress constVariableReference + output = value; + dbgmsg("cdf_directives_t::%s: %s", __func__, str(output).c_str()); + } + T& value() { + return empty()? default_value : std::stack<T>::top(); + } + void push() { + std::stack<T>::push(value()); + dbgmsg("cdf_directives_t::%s: %s", __func__, str(top()).c_str()); + } + void pop() { + if( empty() ) { + error_msg(YYLTYPE(), "CDF stack empty"); // cppcheck-suppress syntaxError + return; + } + default_value = top(); + std::stack<T>::pop(); + dbgmsg("cdf_directives_t::%s: %s", __func__, str(default_value).c_str()); + } + protected: + static std::string str(cbl_call_convention_t arg) { + char output[2] = { static_cast<char>(arg) }; + return std::string("call-convention ") + output; + } + static std::string str(current_tokens_t) { + return "<cobol-words>"; + } + static std::string str(cdf_values_t) { + return "<dictionary>"; + } + static std::string str(source_format_t arg) { + return arg.description(); + } + static std::string str(cbl_enabled_exceptions_t) { + return "<enabled_exceptions>"; + } + }; + + public: + cdf_stack_t<cbl_call_convention_t> call_convention; + cdf_stack_t<current_tokens_t> cobol_words; + cdf_stack_t<cdf_values_t> dictionary; // DEFINE + cdf_stack_t<source_format_t> source_format; + cdf_stack_t<cbl_enabled_exceptions_t> enabled_exceptions; + + cdf_directives_t() { + call_convention.value() = cbl_call_cobol_e; + } + + void push() { + call_convention.push(); + cobol_words.push(); + dictionary.push(); + source_format.push(); + enabled_exceptions.push(); + } + void pop() { + call_convention.pop(); + cobol_words.pop(); + dictionary.pop(); + source_format.pop(); + enabled_exceptions.pop(); + } +}; +static cdf_directives_t cdf_directives; + +void +current_call_convention( cbl_call_convention_t convention) { + cdf_directives.call_convention.value(convention); +} +cbl_call_convention_t +current_call_convention() { + return cdf_directives.call_convention.value(); +} + +current_tokens_t& +cdf_current_tokens() { + return cdf_directives.cobol_words.value(); +} + +cdf_values_t& +cdf_dictionary() { + return cdf_directives.dictionary.value(); +} + +void +cobol_set_indicator_column( int column ) { + cdf_directives.source_format.value().indicator_column_set(column); +} +source_format_t& cdf_source_format() { + return cdf_directives.source_format.value(); +} + +cbl_enabled_exceptions_t& +cdf_enabled_exceptions() { + return cdf_directives.enabled_exceptions.value(); +} + +void cdf_push() { cdf_directives.push(); } +void cdf_push_call_convention() { cdf_directives.call_convention.push(); } +void cdf_push_current_tokens() { cdf_directives.cobol_words.push(); } +void cdf_push_dictionary() { cdf_directives.dictionary.push(); } +void cdf_push_enabled_exceptions() { cdf_directives.enabled_exceptions.push(); } +void cdf_push_source_format() { cdf_directives.source_format.push(); } + +void cdf_pop() { cdf_directives.pop(); } +void cdf_pop_call_convention() { cdf_directives.call_convention.pop(); } +void cdf_pop_current_tokens() { cdf_directives.cobol_words.pop(); } +void cdf_pop_dictionary() { cdf_directives.dictionary.pop(); } +void cdf_pop_enabled_exceptions() { cdf_directives.enabled_exceptions.pop(); } +void cdf_pop_source_format() { cdf_directives.source_format.pop(); } + +/* + * Construct a cbl_field_t from a CDF literal, to be installed in the symbol table. + */ +cbl_field_t +cdf_literalize( const std::string& name, const cdfval_t& value ) { + cbl_field_t field; + + if( value.is_numeric() ) { + auto initial = xasprintf("%ld", (long)value.as_number()); + auto len = strlen(initial); + cbl_field_data_t data(len, len); + data.initial = initial; + data.valify(); + field = cbl_field_t{ FldLiteralN, constant_e, data, 0, name.c_str()}; + } else { + auto len = strlen(value.string); + cbl_field_data_t data(len, len); + data.initial = xstrdup(value.string); + field = cbl_field_t{ FldLiteralA, constant_e, data, 0, name.c_str() }; + field.set_attr(quoted_e); + } + field.codeset.set(); + + return field; +} + +const std::list<cbl_field_t> +cdf_literalize() { + std::list<cbl_field_t> fields; + auto dict = cdf_dictionary(); + + for( auto elem : dict ) { + std::string name(elem.first); + const cdfval_t& value(elem.second); + + fields.push_back(cdf_literalize(name, value)); + } + return fields; +} + 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: return "SymLabel"; case SymSpecial: return "SymSpecial"; + case SymLocale: + return "SymLocale"; case SymAlphabet: return "SymAlphabet"; case SymFile: @@ -112,7 +320,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 "???"; } @@ -158,10 +366,8 @@ cbl_field_type_str( enum cbl_field_type_t type ) return "FldSwitch"; case FldPointer: return "FldPointer"; - 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 "???"; } @@ -321,8 +527,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; } @@ -346,49 +553,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); @@ -446,7 +654,6 @@ is_elementary( enum cbl_field_type_t type ) case FldForward: case FldIndex: case FldSwitch: - case FldBlob: return false; case FldPointer: case FldAlphanumeric: @@ -459,7 +666,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; } @@ -638,6 +845,7 @@ symbol_field_type_update( cbl_field_t *field, // type matches itself if( field->type == candidate ) { if( is_usage ) field->usage = candidate; + field->codeset.set(); return true; } if( is_usage && field->usage == candidate ) return true; @@ -664,7 +872,6 @@ symbol_field_type_update( cbl_field_t *field, */ if( is_usage ) { switch(field->type) { - case FldBlob: case FldDisplay: gcc_unreachable(); // type is never just "display" break; @@ -715,11 +922,24 @@ symbol_field_type_update( cbl_field_t *field, case FldInvalid: field->type = candidate; field->attr |= numeric_group_attrs(field); + // update encoding + switch( field->type ) { + case FldNumericDisplay: + case FldAlphaEdited: + case FldNumericEdited: + { + bool retval = field->codeset.set(); + return retval; + } + default: + break; + } return true; case FldDisplay: if( is_displayable(candidate) ) { field->type = candidate; field->attr |= numeric_group_attrs(field); + if( ! field->codeset.valid() ) return field->codeset.set(); return true; } break; @@ -730,6 +950,7 @@ symbol_field_type_update( cbl_field_t *field, field->clear_attr(all_x_e); field->type = field->usage; field->attr |= numeric_group_attrs(field); + if( ! field->codeset.valid() ) return field->codeset.set(); return true; case FldNumericDisplay: case FldNumericEdited: @@ -741,7 +962,6 @@ symbol_field_type_update( cbl_field_t *field, case FldForward: case FldSwitch: case FldPointer: - case FldBlob: // invalid usage value gcc_unreachable(); break; @@ -771,7 +991,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; @@ -819,7 +1039,7 @@ cbl_field_t::report_invalid_initial_value(const YYLTYPE& loc) const { // 8 or more, we need do no further testing because we assume // everything fits. if( data.capacity < 8 ) { - auto p = strchr(data.initial, symbol_decimal_point()); + const char *p = strchr(data.initial, symbol_decimal_point()); if( p && atoll(p+1) != 0 ) { error_msg(loc, "integer type %s VALUE '%s' " "requires integer VALUE", @@ -882,8 +1102,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%ld)", + name, data.initial, '.', (long)(pend - p)); } } } @@ -915,15 +1135,15 @@ cbl_field_t::report_invalid_initial_value(const YYLTYPE& loc) const { // consider all-alphabetic if( has_attr(all_alpha_e) ) { bool alpha_value = fig != zero_value_e; - + if( fig == normal_value_e ) { - alpha_value = std::all_of( data.initial, - data.initial + - strlen(data.initial), - []( char ch ) { - return ISSPACE(ch) || - ISPUNCT(ch) || - ISALPHA(ch); } ); + alpha_value = std::none_of( data.initial, + data.initial + + data.capacity, + []( char ch ) { + return + ISPUNCT(ch) || + ISDIGIT(ch); } ); } if( ! alpha_value ) { error_msg(loc, "alpha-only %s VALUE '%s' contains non-alphabetic data", @@ -941,8 +1161,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(); @@ -960,32 +1179,31 @@ literal_subscript_oob( const cbl_refer_t& r, size_t& isub /* output */) { * for the corresponding dimension. Return the first subscript not * meeting those criteria, if any. */ - auto p = std::find_if( r.subscripts, esub, - [&pdim]( const cbl_refer_t& r ) { + auto psub = std::find_if( r.subscripts.begin(), r.subscripts.end(), + [pdim]( const cbl_refer_t& r ) mutable { const auto& occurs((*pdim)->occurs); pdim++; return ! occurs.subscript_ok(r.field); } ); - isub = p - r.subscripts; - return p == esub? NULL : dims[isub]; + isub = psub - r.subscripts.begin(); + return psub == r.subscripts.end()? NULL : dims[isub]; } size_t cbl_refer_t::subscripts_set( const std::list<cbl_refer_t>& subs ) { - nsubscript = subs.size(); - subscripts = new cbl_refer_t[nsubscript]; - std::copy( subs.begin(), subs.end(), subscripts ); - + subscripts.clear(); + std::copy( subs.begin(), subs.end(), std::back_inserter(subscripts) ); return dimensions(field); } const char * cbl_refer_t::str() const { - static char subscripts[64]; - sprintf(subscripts, "(%u of %zu dimensions)", nsubscript, dimensions(field)); + static char subscripts_l[64]; + sprintf(subscripts_l, "(%u of " HOST_SIZE_T_PRINT_UNSIGNED " dimensions)", + nsubscript(), (fmt_size_t)dimensions(field)); char *output = xasprintf("%s %s %s", field? field_str(field) : "(none)", - 0 < dimensions(field)? subscripts : "", + 0 < dimensions(field)? subscripts_l : "", is_refmod_reference()? "(refmod)" : "" ); return output; } @@ -998,18 +1216,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()); @@ -1028,10 +1246,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); @@ -1086,10 +1304,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: @@ -1099,11 +1315,10 @@ valid_move( const struct cbl_field_t *tgt, const struct cbl_field_t *src ) return false; // parser should not allow the following types here 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; } @@ -1129,15 +1344,25 @@ valid_move( const struct cbl_field_t *tgt, const struct cbl_field_t *src ) case 0: if( src->type == FldLiteralA && is_numericish(tgt) && !is_literal(tgt) ) { // Allow if input string is an integer. - const char *p = src->data.initial, *pend = p + src->data.capacity; - if( p[0] == '+' || p[0] == '-' ) p++; + size_t outcount; + char *in_ascii = static_cast<char *>(xmalloc(4 * src->data.capacity)); + const char *in_asciip = __gg__iconverter( src->codeset.encoding, + DEFAULT_SOURCE_ENCODING, + src->data.initial, + src->data.capacity, + &outcount ); + memcpy(in_ascii, in_asciip, outcount); + const char *p = in_ascii, *pend = p + src->data.capacity; + if( (p[0] == ascii_plus) || (p[0] == ascii_minus) ) p++; retval = std::all_of( p, pend, isdigit ); 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)); } + free(in_ascii); } break; case 1: @@ -1169,12 +1394,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; } @@ -1182,8 +1401,6 @@ bool valid_picture( enum cbl_field_type_t type, const char picture[] ) { switch(type) { - case FldBlob: - gcc_unreachable(); // can't get here via the parser case FldInvalid: case FldGroup: case FldLiteralA: @@ -1228,7 +1445,6 @@ uint32_t type_capacity( enum cbl_field_type_t type, uint32_t digits ) { switch(type) { - case FldBlob: gcc_unreachable(); case FldInvalid: case FldGroup: case FldAlphanumeric: @@ -1366,7 +1582,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) {} @@ -1375,13 +1591,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)); } @@ -1412,7 +1621,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; @@ -1440,16 +1649,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. @@ -1470,9 +1670,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()) ); } @@ -1482,9 +1679,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) ); } @@ -1515,10 +1709,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); } @@ -1545,7 +1740,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 ) { @@ -1561,9 +1756,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 ); @@ -1582,15 +1777,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; } @@ -1661,8 +1858,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 ); @@ -1670,8 +1868,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; } @@ -1711,12 +1910,13 @@ date_time_fmt( const char input[] ) { { regex_t(), 'd', "^(" DATE_FMT_B "|" DATE_FMT_E ")$" }, { regex_t(), 't', "^(" TIME_FMT_B "|" TIME_FMT_E ")$" }, }; - int erc, cflags = REG_EXTENDED | REG_ICASE, eflags=0; + int cflags = REG_EXTENDED | REG_ICASE, eflags=0; regmatch_t m[5]; char result = 0; if( ! compiled ) { for( auto& fmt : fmts ) { + int erc; if( (erc = regcomp(&fmt.reg, fmt.pattern, cflags)) != 0 ) { char msg[80]; regerror(erc, &fmt.reg, msg, sizeof(msg)); @@ -1749,11 +1949,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(); } @@ -1772,14 +1971,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(); @@ -1790,21 +2004,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"); } }; @@ -1813,6 +2045,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 @@ -1823,46 +2061,60 @@ 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); } - inode = p->second; - assert(inode != 0); + else { + inode = p->second; + assert(inode != 0); + } } linemap_add(line_table, LC_ENTER, sysp, name, 1); input_filename_vestige = name; - bool pushed = input_filenames.push( input_file_t(name, inode, 1, lines) ); - input_filenames.top().lineno = yylineno = 1; - 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; + 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() ); @@ -1870,26 +2122,70 @@ cobol_filename_restore() { input_filename_vestige = top.name; input_filenames.pop(); - if( input_filenames.empty() ) return NULL; + if( input_filenames.empty() ) return; - auto& input = input_filenames.top(); + const auto& input = input_filenames.top(); - input.lines = linemap_add(line_table, LC_LEAVE, sysp, NULL, 0); + 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); +size_t +symbol_unique_index( const struct symbol_elem_t *e ) { + assert(e); + size_t usym = symbol_index(e); +#if READY_FOR_INODE + if( ! input_filenames.empty() ) { + size_t inode = input_filenames.top().inode; + usym = usym ^ inode; } - return input.name; +#endif + return usym; } -static location_t token_location; +static int first_line_minus_1 = 0; +static location_t token_location_minus_1 = 0; +static location_t token_location = 0; + +location_t current_token_location() { return token_location; } +location_t current_token_location(const location_t& loc) { + return token_location = loc; +} +location_t current_location_minus_one() { return token_location_minus_1; } +void current_location_minus_one_clear() + { + first_line_minus_1 = 0; + } +/* + * Update global token_location with a location_t expressing a source range + * with start and caret at the first line/column of LOC, and finishing at the + * last line/column of LOC. + */ template <typename LOC> static void gcc_location_set_impl( const LOC& loc ) { - token_location = linemap_line_start( line_table, loc.last_line, 80 ); - token_location = linemap_position_for_column( line_table, loc.first_column); + // Set the position to the first line & column in the location. + static location_t loc_m_1 = 0; + const location_t + start_line = linemap_line_start( line_table, loc.first_line, 80 ), + token_start = linemap_position_for_column( line_table, loc.first_column), + finish_line = linemap_line_start( line_table, loc.last_line, 80 ), + token_finish = linemap_position_for_column( line_table, loc.last_column); + token_location = make_location (token_start, token_start, token_finish); + + if( loc.first_line > first_line_minus_1 ) { + // In order for GDB-COBOL to be able to step through COBOL code properly, + // it is sometimes necessary for the code at the beginning of a COBOL + // line to be using the location_t of the previous line. This is true, for + // example, when laying down the infrastructure code between the last + // statement of a paragraph and the code created at the beginning of the + // following paragragh. This code assumes that token_location values of + // interest are monotonic, and stores that prior value. + first_line_minus_1 = loc.first_line; + token_location_minus_1 = loc_m_1; + loc_m_1 = token_location; + } + location_dump(__func__, __LINE__, "parser", loc); } @@ -1912,11 +2208,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); @@ -1932,9 +2226,16 @@ verify_format( const char gmsgid[] ) { } #endif -static const diagnostic_option_id option_zero; +static const diagnostics::option_id option_zero; size_t parse_error_inc(); +void gcc_location_dump() { + linemap_dump_location( line_table, token_location, stderr ); +} + + +void ydferror( const char gmsgid[], ... ) ATTRIBUTE_GCOBOL_DIAG(1, 2); + void ydferror( const char gmsgid[], ... ) { verify_format(gmsgid); @@ -1943,8 +2244,9 @@ ydferror( const char gmsgid[], ... ) { va_list ap; va_start (ap, gmsgid); rich_location richloc (line_table, token_location); - bool ret = global_dc->diagnostic_impl (&richloc, nullptr, option_zero, - gmsgid, &ap, DK_ERROR); + /*bool ret =*/ global_dc->diagnostic_impl (&richloc, nullptr, option_zero, + gmsgid, &ap, + diagnostics::kind::error); va_end (ap); } @@ -1957,7 +2259,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) { @@ -1965,14 +2267,11 @@ class temp_loc_t : protected YYLTYPE { gcc_location_set(yylloc); // use lookahead location } - temp_loc_t( const YYLTYPE& loc) : orig(token_location) { + explicit temp_loc_t( const YYLTYPE& loc) : orig(token_location) { gcc_location_set(loc); } - temp_loc_t( const YDFLTYPE& loc) : orig(token_location) { - YYLTYPE lloc = { - loc.first_line, loc.first_column, - loc.last_line, loc.last_column }; - gcc_location_set(lloc); + explicit temp_loc_t( const YDFLTYPE& loc) : orig(token_location) { + gcc_location_set(loc); } ~temp_loc_t() { if( orig != token_location ) { @@ -2002,7 +2301,8 @@ class temp_loc_t : protected YYLTYPE { va_start (ap, gmsgid); \ rich_location richloc (line_table, token_location); \ bool ret = global_dc->diagnostic_impl (&richloc, nullptr, option_zero, \ - gmsgid, &ap, DK_ERROR); \ + gmsgid, &ap, \ + diagnostics::kind::error); \ va_end (ap); \ global_dc->end_group(); @@ -2011,18 +2311,38 @@ void error_msg( const YYLTYPE& loc, const char gmsgid[], ... ) { ERROR_MSG_BODY } +void error_msg( const YDFLTYPE& loc, const char gmsgid[], ... ) + ATTRIBUTE_GCOBOL_DIAG(2, 3); + void error_msg( const YDFLTYPE& loc, const char gmsgid[], ... ) { ERROR_MSG_BODY } -void -cdf_location_set(YYLTYPE loc) { - extern YDFLTYPE ydflloc; +bool +warn_msg( const YYLTYPE& loc, const char gmsgid[], ... ) { + temp_loc_t looker(loc); + verify_format(gmsgid); + auto_diagnostic_group d; + va_list ap; + va_start (ap, gmsgid); + rich_location richloc (line_table, token_location); + auto ret = emit_diagnostic_valist( diagnostics::kind::warning, + token_location, + option_zero, gmsgid, &ap ); + va_end (ap); + return ret; +} - ydflloc.first_line = loc.first_line; - ydflloc.first_column = loc.first_column; - ydflloc.last_line = loc.last_line; - ydflloc.last_column = loc.last_column; +void error_msg_direct( const char gmsgid[], ... ) { + verify_format(gmsgid); + parse_error_inc(); + auto_diagnostic_group d; + va_list ap; + va_start (ap, gmsgid); + /*auto ret = */emit_diagnostic_valist( diagnostics::kind::error, + token_location, + option_zero, gmsgid, &ap ); + va_end (ap); } void @@ -2034,24 +2354,15 @@ yyerror( const char gmsgid[], ... ) { va_list ap; va_start (ap, gmsgid); rich_location richloc (line_table, token_location); - bool ret = global_dc->diagnostic_impl (&richloc, nullptr, option_zero, - gmsgid, &ap, DK_ERROR); + /*bool ret =*/ global_dc->diagnostic_impl ( &richloc, + nullptr, + option_zero, + gmsgid, + &ap, diagnostics::kind::error); va_end (ap); global_dc->end_group(); } -bool -yywarn( const char gmsgid[], ... ) { - verify_format(gmsgid); - auto_diagnostic_group d; - va_list ap; - va_start (ap, gmsgid); - auto ret = emit_diagnostic_valist( DK_WARNING, token_location, - option_zero, gmsgid, &ap ); - va_end (ap); - return ret; -} - /* * Sometimes during parsing an error is noticed late. This message refers back * to an arbitrary file and line number. @@ -2078,7 +2389,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; @@ -2091,7 +2402,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; } @@ -2099,10 +2410,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 @@ -2110,41 +2421,42 @@ cobol_fileline_set( const char line[] ) { *filename = xstrndup(line + pmatch[2].rm_so, matched_length(pmatch[2])); int fileline; - if( 1 != sscanf(line_str, "%d", &fileline) ) - yywarn("could not parse line number %s from #line directive", line_str); - + if( 1 != sscanf(line_str, "%d", &fileline) ) { + cbl_message(LexLineE, + "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[] ) @@ -2155,15 +2467,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); @@ -2187,30 +2509,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"); + cbl_message(ParLocaleW, "setlocale: unable to initialize LOCALE"); } else { char *codeset = nl_langinfo(CODESET); if( ! codeset ) { - yywarn("nl_langinfo failed after setlocale succeeded"); + cbl_message(ParLangInfoW, "%<nl_langinfo%> failed after %<setlocale()%> succeeded"); } else { os_locale.codeset = codeset; } @@ -2222,19 +2534,6 @@ cobol_parse_files (int nfile, const char **files) } } -/* Outputs the formatted string onto the file descriptor */ - -void -cbl_message(int fd, const char *format_string, ...) - { - va_list ap; - va_start(ap, format_string); - char *ostring = xvasprintf(format_string, ap); - va_end(ap); - write(fd, ostring, strlen(ostring)); - free(ostring); - } - /* Uses the GCC internal_error () to output the formatted string. Processing ends with a stack trace */ @@ -2244,18 +2543,37 @@ cbl_internal_error(const char *gmsgid, ...) { auto_diagnostic_group d; va_list ap; va_start(ap, gmsgid); - emit_diagnostic_valist( DK_ICE, token_location, option_zero, gmsgid, &ap ); + emit_diagnostic_valist( diagnostics::kind::ice, + token_location, option_zero, gmsgid, &ap ); va_end(ap); + abort(); // This unnecessary statement is needed so that [[noreturn]] + // // doesn't cause a warning. } +diagnostics::kind cbl_diagnostic_kind( cbl_diag_id_t id ); +const char * cbl_diagnostic_option( cbl_diag_id_t id ); + void -cbl_unimplementedw(const char *gmsgid, ...) { +cbl_unimplementedw(cbl_diag_id_t id, const char *gmsgid, ...) { verify_format(gmsgid); auto_diagnostic_group d; + const char *option; + char *msg = nullptr; + + diagnostics::kind kind = cbl_diagnostic_kind(id); + if( kind == diagnostics::kind::ignored ) return; + + if( (option = cbl_diagnostic_option(id)) != nullptr ) { + msg = xasprintf("%s [%s]", gmsgid, option); + gmsgid = msg; + } + va_list ap; + va_start(ap, gmsgid); - emit_diagnostic_valist( DK_SORRY, token_location, option_zero, gmsgid, &ap ); + emit_diagnostic_valist( kind, token_location, option_zero, gmsgid, &ap ); va_end(ap); + free(msg); } void @@ -2264,7 +2582,8 @@ cbl_unimplemented(const char *gmsgid, ...) { auto_diagnostic_group d; va_list ap; va_start(ap, gmsgid); - emit_diagnostic_valist( DK_SORRY, token_location, option_zero, gmsgid, &ap ); + emit_diagnostic_valist( diagnostics::kind::sorry, + token_location, option_zero, gmsgid, &ap ); va_end(ap); } @@ -2275,12 +2594,13 @@ cbl_unimplemented_at( const YYLTYPE& loc, const char *gmsgid, ... ) { auto_diagnostic_group d; va_list ap; va_start(ap, gmsgid); - emit_diagnostic_valist( DK_SORRY, token_location, option_zero, gmsgid, &ap ); + emit_diagnostic_valist( diagnostics::kind::sorry, + token_location, option_zero, gmsgid, &ap ); va_end(ap); } -/* - * analogs to err(3) and errx(3). +/* + * analogs to err(3) and errx(3). */ #pragma GCC diagnostic push @@ -2292,7 +2612,8 @@ cbl_err(const char *fmt, ...) { verify_format(gmsgid); va_list ap; va_start(ap, fmt); - emit_diagnostic_valist( DK_FATAL, token_location, option_zero, gmsgid, &ap ); + emit_diagnostic_valist( diagnostics::kind::fatal, + token_location, option_zero, gmsgid, &ap ); va_end(ap); } #pragma GCC diagnostic pop @@ -2303,10 +2624,18 @@ cbl_errx(const char *gmsgid, ...) { auto_diagnostic_group d; va_list ap; va_start(ap, gmsgid); - emit_diagnostic_valist( DK_FATAL, token_location, option_zero, gmsgid, &ap ); + emit_diagnostic_valist( diagnostics::kind::fatal, + token_location, option_zero, gmsgid, &ap ); va_end(ap); } +/* + * For a function that uses host *printf, %zu or %td or %wu are not ok, sadly. + * not all supported host arches support those. So, for *printf family one + * needs to use macros like HOST_WIDE_INT_PRINT_DEC (for HOST_WIDE_INT + * argument), or HOST_SIZE_T_PRINT_UNSIGNED (for size_t, with casts to + * (fmt_size_t)). + */ void dbgmsg(const char *msg, ...) { if( yy_flex_debug || yydebug ) { @@ -2319,12 +2648,6 @@ 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", - term, dialect); -} - bool fisdigit(int c) { return ISDIGIT(c); @@ -2332,12 +2655,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..d457e3e 100644 --- a/gcc/cobol/util.h +++ b/gcc/cobol/util.h @@ -31,19 +31,96 @@ #ifndef _UTIL_H_ #define _UTIL_H_ -void cbl_message(int fd, const char *format_string, ...); -void cbl_internal_error(const char *format_string, ...); +[[noreturn]] void cbl_internal_error(const char *format_string, ...) + ATTRIBUTE_GCOBOL_DIAG(1, 2); -void cbl_err(const char *format_string, ...); -void cbl_errx(const char *format_string, ...); +void cbl_err(const char *format_string, ...) ATTRIBUTE_GCOBOL_DIAG(1, 2); +void cbl_errx(const char *format_string, ...) ATTRIBUTE_GCOBOL_DIAG(1, 2); bool fisdigit(int c); bool fisspace(int c); int ftolower(int c); +int ftoupper(int c); bool fisprint(int c); -const char * cobol_filename_restore(); -const char * cobol_lineno_save(); +void cobol_set_pp_option(int opt); +void cobol_filename_restore(); +const char * cobol_lineno( int ); +int cobol_lineno(void); + +unsigned long gb4( size_t input ); + +template <typename P> +static inline const void * +as_voidp( P p ) { + return static_cast<const void *>(p); +} + +/* + * The default source format, whether free or fixed, is determined + * heuristically by examining the PROGRAM-ID line, if it exists, in the first + * input file. If that file does not have such a line, the default is free + * format. Else the format is set to fixed if anything appears on that line + * that would prohibit parsing it as free format, + */ +class source_format_t { + bool first_file, explicitly; + int left, right; +public: + source_format_t() + : first_file(true), explicitly(false), left(0), right(0) + {} + void indicator_column_set( int column ) { + explicitly = true; + if( column == 0 ) right = 0; + if( column < 0 ) { + column = -column; + right = 73; + } + left = column; + } + + bool inference_pending() { + bool tf = first_file && !explicitly; + first_file = false; + return tf; + } + + void infer( const char *bol, bool want_reference_format ); + + inline bool is_fixed() const { return left == 7; } + inline bool is_reffmt() const { return is_fixed() && right == 73; } + inline bool is_free() const { return ! is_fixed(); } + + const char * description() const { + if( is_reffmt() ) return "REFERENCE"; + if( is_fixed() ) return "FIXED"; + if( is_free() ) return "FREE"; + gcc_unreachable(); + } + + inline int left_margin() { + return left == 0? left : left - 1; + } + inline int right_margin() { + return right == 0? right : right - 1; + } +}; + + +void cdf_push(); +void cdf_push_call_convention(); +void cdf_push_current_tokens(); +void cdf_push_dictionary(); +void cdf_push_enabled_exceptions(); +void cdf_push_source_format(); + +void cdf_pop(); +void cdf_pop_call_convention(); +void cdf_pop_current_tokens(); +void cdf_pop_dictionary(); +void cdf_pop_source_format(); +void cdf_pop_enabled_exceptions(); #endif |