From: Robert Dubner Date: Sat, 25 Jul 2026 04:57:49 +0000 (-0400) Subject: cobol: ACCEPT into subscripted and reference-modified variables. X-Git-Url: http://git.ipfire.org/gitweb.cgi?a=commitdiff_plain;h=642bd002d5d4e13fa8c5fefdc936414859052e31;p=thirdparty%2Fgcc.git cobol: ACCEPT into subscripted and reference-modified variables. The principal changes here are so that ACCEPT X(N) FROM and ACCEPT Y(A:B) FROM work. Another set of changes modifies SELECT ASSIGN to handle certain IBM requirements about TO DEVICE syntax. There are also changes here that improve the execution time of certain types of MOVE statements. gcc/cobol/ChangeLog: * cbldiag.h (struct cbl_loc_t): Mollify cppcheck. * gcobol.1: Documentation. * genapi.cc (parser_accept_date_yymmdd): Changes to ACCEPT. (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. (walk_initialization): Propagate based_e attribute to child variables. (parser_file_open): SELECT ASSIGN TO DEVICE changes. (parser_call): Include function name in error message when the function name cannot be found. * genapi.h (parser_accept_date_yymmdd): Changes to ACCEPT. (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. * genutil.cc (FIXED_WIDE_INT): Potential improvement to MOVE statements involving intermediate_e variables. (get_power_of_two): Likewise. * genutil.h (FIXED_WIDE_INT): Likewise. * lexio.h (struct filespan_t): Mollify cppcheck. * move.cc (mh_identical): Improve MOVE execution speed. (copy_native_into_place): Likewise. (copy_intermediate_into_place): Likewise. (mh_to_binary): Likewise. (move_helper): Likewise. * parse.y: Changes to ACCEPT. * symbols.cc (symbol_table_init): Add external_e attribute to DEBUG-ITEM and children. (new_temporary_impl): Mollify cppcheck. * symfind.cc (struct funcname): Likewise. * util.cc (determine_intermediate_type): Set output.data.digits to zero. libgcobol/ChangeLog: * constants.cc (struct cblc_field_t): Add external_e attribute to DEBUG-ITEM and children. * libgcobol.cc (field_from_ascii): Changes to ACCEPT. (__gg__get_date_yymmdd): Likewise. (__gg__get_date_yyyymmdd): Likewise. (__gg__get_date_yyddd): Likewise. (__gg__get_yyyyddd): Likewise. (__gg__get_date_dow): Likewise. (__gg__get_date_hhmmssff): Likewise. (format_for_display_internal): Initialize an automatic variable. (default_exception_handler): Include function name in "missing function" run-time error. (__gg__set_exception_code): Likewise. (__gg__set_exception_call): Likewise. gcc/testsuite/ChangeLog: * cobol.dg/group2/ACCEPT_FROM__date__with_subscripts_and_refmods.cob: New test. * cobol.dg/group2/ACCEPT_FROM__date__with_subscripts_and_refmods.out: New test. * cobol.dg/group2/MOVE__identical__operations.cob: New test. * cobol.dg/group2/MOVE__identical__operations.out: New test. * cobol.dg/group2/RT3574_PR__40-_Repository_section_intrinsic_funcs.cob: New test. --- diff --git a/gcc/cobol/cbldiag.h b/gcc/cobol/cbldiag.h index aefdfaba394..22d703b2cad 100644 --- a/gcc/cobol/cbldiag.h +++ b/gcc/cobol/cbldiag.h @@ -107,7 +107,7 @@ struct cbl_loc_base_t { }; struct cbl_loc_t : public cbl_loc_base_t { - cbl_loc_t() = default; + cbl_loc_t() = default; // cppcheck-suppress uninitDerivedMemberVar cbl_loc_t( int first_line, int first_column, int last_line, int last_column ) diff --git a/gcc/cobol/gcobol.1 b/gcc/cobol/gcobol.1 index c1afc53841a..5eac3beef59 100644 --- a/gcc/cobol/gcobol.1 +++ b/gcc/cobol/gcobol.1 @@ -97,7 +97,7 @@ compiles \*[lang] source code to object code, and optionally produces an executable binary or shared object. As a GCC component, it accepts all options that affect code-generation and linking. Options specific to \*[lang] are listed below. -.Bl -tag -width "\0\0debug" +.Bl -tag -width 00debug .It Fl main Ar filename .Nm will generate a @@ -714,7 +714,6 @@ Warn if a SEGMENT range is negative (instead of error). Warn if IBM-style STOP 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 @@ -1395,7 +1394,7 @@ suite has been identified. . .Ss CDF Text Manipulation .Bl -tag -width >>DEFINE -.It Sy COPY Ar copybook Li Oo OF|IN Ar library Oc Oo Sy REPLACING ... Oc +.It Sy COPY Ar copybook Oo Li OF|IN 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 @@ -2061,7 +2060,7 @@ to see it compile, please get in touch with the developers. .El . .Ss Status of NIST \*[lang] Compiler Verification Suite -.Bl -tag -compact -width "\0\0100% NC" +.Bl -tag -compact -width "00100% NC" .It NC 100% Nucleus .It SQ 100% @@ -2160,22 +2159,22 @@ to the I/O support will be readily available to the paying customer. .El . .Sh COPYRIGHT -.Bd -unfilled -indent +.Bd -unfilled Copyright (c) 2021-2026 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. +\(bu Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +\(bu 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. +\(bu 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 diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 46e2fc743d3..9ad300878f9 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -4225,7 +4225,7 @@ parser_set_envar( const struct cbl_refer_t &name, } void -parser_accept_date_yymmdd( struct cbl_field_t *target ) +parser_accept_date_yymmdd( const cbl_refer_t& refer ) { Analyze(); SHOW_PARSE @@ -4234,11 +4234,14 @@ parser_accept_date_yymmdd( struct cbl_field_t *target ) SHOW_PARSE_END } + auto target = refer.field; CHECK_FIELD(target); gg_call(VOID, "__gg__get_date_yymmdd", gg_get_address_of(target->var_decl_node), + refer_offset(refer), + refer_size_dest(refer), NULL_TREE); TRACE1 { @@ -4249,7 +4252,7 @@ parser_accept_date_yymmdd( struct cbl_field_t *target ) } void -parser_accept_date_yyyymmdd( struct cbl_field_t *target ) +parser_accept_date_yyyymmdd( const cbl_refer_t& refer ) { Analyze(); SHOW_PARSE @@ -4257,9 +4260,12 @@ parser_accept_date_yyyymmdd( struct cbl_field_t *target ) SHOW_PARSE_HEADER SHOW_PARSE_END } + auto target = refer.field; gg_call(VOID, "__gg__get_date_yyyymmdd", gg_get_address_of(target->var_decl_node), + refer_offset(refer), + refer_size_dest(refer), NULL_TREE); TRACE1 { @@ -4270,7 +4276,7 @@ parser_accept_date_yyyymmdd( struct cbl_field_t *target ) } void -parser_accept_date_yyddd( struct cbl_field_t *target ) +parser_accept_date_yyddd( const cbl_refer_t& refer ) { Analyze(); SHOW_PARSE @@ -4279,11 +4285,14 @@ parser_accept_date_yyddd( struct cbl_field_t *target ) SHOW_PARSE_END } + auto target = refer.field; CHECK_FIELD(target); gg_call(VOID, "__gg__get_date_yyddd", gg_get_address_of(target->var_decl_node), + refer_offset(refer), + refer_size_dest(refer), NULL_TREE); TRACE1 { @@ -4294,7 +4303,7 @@ parser_accept_date_yyddd( struct cbl_field_t *target ) } void -parser_accept_date_yyyyddd( struct cbl_field_t *target ) +parser_accept_date_yyyyddd( const cbl_refer_t& refer ) { Analyze(); SHOW_PARSE @@ -4303,11 +4312,14 @@ parser_accept_date_yyyyddd( struct cbl_field_t *target ) SHOW_PARSE_END } + auto target = refer.field; CHECK_FIELD(target); gg_call(VOID, "__gg__get_yyyyddd", gg_get_address_of(target->var_decl_node), + refer_offset(refer), + refer_size_dest(refer), NULL_TREE); TRACE1 { @@ -4318,7 +4330,7 @@ parser_accept_date_yyyyddd( struct cbl_field_t *target ) } void -parser_accept_date_dow( struct cbl_field_t *target ) +parser_accept_date_dow( const cbl_refer_t& refer ) { Analyze(); SHOW_PARSE @@ -4327,11 +4339,14 @@ parser_accept_date_dow( struct cbl_field_t *target ) SHOW_PARSE_END } + auto target = refer.field; CHECK_FIELD(target); gg_call(VOID, "__gg__get_date_dow", gg_get_address_of(target->var_decl_node), + refer_offset(refer), + refer_size_dest(refer), NULL_TREE); TRACE1 { @@ -4342,7 +4357,7 @@ parser_accept_date_dow( struct cbl_field_t *target ) } void -parser_accept_date_hhmmssff( struct cbl_field_t *target ) +parser_accept_date_hhmmssff( const cbl_refer_t& refer ) { Analyze(); SHOW_PARSE @@ -4351,11 +4366,14 @@ parser_accept_date_hhmmssff( struct cbl_field_t *target ) SHOW_PARSE_END } + auto target = refer.field; CHECK_FIELD(target); gg_call(VOID, "__gg__get_date_hhmmssff", gg_get_address_of(target->var_decl_node), + refer_offset(refer), + refer_size_dest(refer), NULL_TREE); TRACE1 { @@ -5787,6 +5805,10 @@ walk_initialization(cbl_field_t *field, bool initialized, bool deallocate) } } first_time = false; + + // We need to propagate the based_e attribute: + cbl_field_of(&element)->attr |= based_e; + if( this_one->level == 00 ) { // Ignore LEVEL00 "INDEXED BY" variables @@ -9113,17 +9135,15 @@ parser_file_open( struct cbl_file_t *file, int mode_char ) } -//#pragma message "parser_file_open: consult cbl_file_t::filename_of and cbl_file_t::device" - /* - * The filename of a cbl_file_t may be found in three places: + * The filename of a cbl_file_t may be found in three places: * 1. As before, in the cbl_field_t indexed by cbl_file_t::filename. * 2. Now, in the cbl_special_name_t indexed by cbl_file_t::device. - * 3. As ever, in neither, from the environment. + * 3. As ever, in neither, from the environment. * * If both filename and device are nonzero and not FldForward, the filename - * supersedes. The syntax was - * SELECT fd-name ASSIGN TO device-name USING filename + * supersedes. The syntax was + * SELECT fd-name ASSIGN TO device-name USING filename * That just creates in the parser an alias of device-name to fd-name. It's * still the same file and does *not* change the device characteristics. * @@ -9131,11 +9151,9 @@ parser_file_open( struct cbl_file_t *file, int mode_char ) * taken from cbl_special_name_t::os_filename. It is tiny, hard-coded name * in /dev. * - * Upon implementation please feel free to delete this message. * --jkl */ - tree pszFilename = gg_define_char_star(); cbl_field_t *field_of_name = symbol_field_forward(file->filename); if( field_of_name->type == FldForward ) @@ -13127,7 +13145,13 @@ parser_call( cbl_refer_t name, } ELSE { - // We have a bad function pointer, which is the except condition: + // We have a bad function pointer, which is the exception condition: + // Set the exception message to "name" + gg_call(VOID, + "__gg__set_exception_call", + gg_get_address_of(name.field->var_decl_node), + refer_offset(name), + NULL_TREE); parser_exception_raise(ec_program_not_found_e); if( except ) { diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h index a09246be6de..de3825ac263 100644 --- a/gcc/cobol/genapi.h +++ b/gcc/cobol/genapi.h @@ -80,12 +80,12 @@ void parser_accept_command_line(const cbl_refer_t &tgt, 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 ); -void parser_accept_date_yyddd( cbl_field_t *tgt ); -void parser_accept_date_yyyyddd( cbl_field_t *tgt ); -void parser_accept_date_dow( cbl_field_t *tgt ); -void parser_accept_date_hhmmssff( cbl_field_t *tgt ); +void parser_accept_date_yymmdd( const cbl_refer_t& tgt ); +void parser_accept_date_yyyymmdd( const cbl_refer_t& tgt ); +void parser_accept_date_yyddd( const cbl_refer_t& tgt ); +void parser_accept_date_yyyyddd( const cbl_refer_t& tgt ); +void parser_accept_date_dow( const cbl_refer_t& tgt ); +void parser_accept_date_hhmmssff( const cbl_refer_t& tgt ); void parser_alphabet( const cbl_alphabet_t *alphabet ); diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc index b26a0993009..bb6172f3db3 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -1059,6 +1059,36 @@ get_power_of_ten(int n) return retval; } +FIXED_WIDE_INT(128) +get_power_of_two(int nbytes) + { + // This is used for determining if a binary value is truncated as part of a + // move to pure binary variable. + FIXED_WIDE_INT(128) retval = 1; + static const int MAX_POWER = 8 ; + static const unsigned long long pos[MAX_POWER+1] = + { + 1ULL, // 0 byte + 256ULL, // 1 bytes + 65536ULL, // 2 + 16777216ULL, // 3 + 4294967296ULL, // 4 + 1099511627776ULL, // 5 + 281474976710656ULL, // 6 + 72057594037927936ULL, // 7 + }; + if( nbytes < MAX_POWER ) + { + retval = pos[nbytes]; + } + else + { + retval = pos[nbytes]; + retval *= retval; + } + return retval; + } + void scale_by_power_of_ten_N(tree value, int N, diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h index dd96ea3ff34..c01e7972359 100644 --- a/gcc/cobol/genutil.h +++ b/gcc/cobol/genutil.h @@ -73,6 +73,8 @@ 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); +// cppcheck-suppress unknownMacro +FIXED_WIDE_INT(128) get_power_of_two(int nbytes); tree scale_by_power_of_ten(tree value, tree N, bool check_for_fractional = false); diff --git a/gcc/cobol/lexio.h b/gcc/cobol/lexio.h index 222a831fe6d..f1eddad54e5 100644 --- a/gcc/cobol/lexio.h +++ b/gcc/cobol/lexio.h @@ -168,7 +168,7 @@ struct filespan_t : public bytespan_t { if( nul != eol ) { if( std::any_of( nul, eodata, []( char ch ) { return ch != '\0'; } ) ) { - int icol = nul - cur; + int icol = nul - cur; // cppcheck-suppress shadowVariable fprintf(stderr, "%s:%d:%d: error: NUL character detected in input\n%*s\n", cobol_filename(), int(iline + 1), ++icol, int(eol - cur), cur); diff --git a/gcc/cobol/move.cc b/gcc/cobol/move.cc index 6f147907444..e0d198d9e3b 100644 --- a/gcc/cobol/move.cc +++ b/gcc/cobol/move.cc @@ -175,24 +175,18 @@ mh_identical(const cbl_refer_t &destref, && (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 + && !sourceref.refmod.from + && !sourceref.refmod.len + && !destref.refmod.from + && !destref.refmod.len + && !sourceref.subscripts.size() + && !destref.subscripts.size() + && !(sourceref.field->attr & intermediate_e) + && !(destref.field->attr & intermediate_e) + && !(sourceref.field->attr & any_length_e) + && !(destref.field->attr & any_length_e) ) { - // These next tests were added because of the DEBUG- registers, which are - // global external, and most of which have a parent. It turns out that - // get_location gets flummoxed by that, so we divert it here to the library - if( sourceref.field->parent - && sourceref.field->data_decl_node - && DECL_EXTERNAL(sourceref.field->data_decl_node) ) - { - return false; - } - if( destref.field->parent - && destref.field->data_decl_node - && DECL_EXTERNAL(destref.field->data_decl_node) ) - { - return false; - } - // The source and destination are identical in type and the // source doesn't have a depending_on clause SHOW_PARSE1 @@ -200,22 +194,18 @@ mh_identical(const cbl_refer_t &destref, SHOW_PARSE_INDENT SHOW_PARSE_TEXT("mh_identical()"); } - if( refer_is_super_clean(destref) - && refer_is_super_clean(sourceref) ) - { - // They are identical, and they have no subscripts - tree source; - tree dest; - get_location(source, sourceref); - get_location(dest, destref); + // They are identical, and they have no refmods or subscripts + tree source; + tree dest; + get_location(source, sourceref); + get_location(dest, destref); - gg_memcpy(dest, - source, - build_int_cst_type(SIZE_T, - destref.field->data.capacity())); - moved = true; - } + gg_memcpy(dest, + source, + build_int_cst_type(SIZE_T, + destref.field->data.capacity())); + moved = true; } return moved; } @@ -1779,12 +1769,22 @@ copy_native_into_place(cbl_field_t *dest, bool check_for_error, const tree &size_error) { + tree value_type = TREE_TYPE(value); + tree dest_type = tree_type_from_field(dest); + + if( gg_sizeof(dest_type) > gg_sizeof(value_type) ) + { + // Because the dest_type is greater than the value_type, we don't need to + // do any size checking. + check_for_error = false; + } + if( !(dest->attr & signable_e) ) { gg_assign(value, gg_abs(value)); } - if( check_for_error ) + if( check_for_error && dest->data.digits) { // We need to see if value can fit into destref @@ -1813,11 +1813,143 @@ copy_native_into_place(cbl_field_t *dest, scale_by_power_of_ten_N(value, dest->data.rdigits - rhs_rdigits); // Create a variable of our target type. + tree target = gg_define_variable(dest_type); + // Cast the source to the target + gg_assign(target, gg_cast(dest_type, value)); + + if( check_for_error && !dest->data.digits ) + { + // The destination is pure binary. Make sure we fit: + int nbytes = gg_sizeof(dest_type); + // We are making sure that value is less than the power of two + FIXED_WIDE_INT(128) power_of_two = get_power_of_two(nbytes); + tree p_of_two = wide_int_to_tree(value_type, power_of_two); + + IF( value, ge_op, p_of_two ) + { + // Flag the size error + gg_assign(size_error, gg_bitwise_or(size_error, integer_one_node)); + } + ELSE + { + } + ENDIF + } + + tree dest_pointer = gg_define_variable(UCHAR_P); + gg_assign(dest_pointer, gg_add(member(dest->var_decl_node, "data"), + dest_offset)); + + if( dest->type == FldNumericBinary ) + { + // We need the target to be big-endian. + if( BYTES_BIG_ENDIAN ) + { + // 'target' is already big-endian, so we can leave it be. + } + else + { + // 'target' is little-endian, so make it big-endian + gg_assign(target, gg_bswap(target)); + } + } + else + { + // We need the target to be native binary, so just leave it be + } + // Copy the target to the destination. + gg_memcpy(dest_pointer, + gg_get_address_of(target), + build_int_cst_type(SIZE_T, gg_sizeof(dest_type))); + } + +static void +copy_intermediate_into_place(cbl_field_t *dest, + tree dest_offset, + tree value, + tree rhs_rdigits, + bool check_for_error, + const tree &size_error) + { + // This is just like copy_native_into_place, except that we picked up the + // number of rdigits, which isn't a constant, from the intermediate source. + + tree value_type = TREE_TYPE(value); tree dest_type = tree_type_from_field(dest); + + if( gg_sizeof(dest_type) > gg_sizeof(value_type) ) + { + // Because the dest_type is greater than the value_type, we don't need to + // do any size checking. + check_for_error = false; + } + + if( !(dest->attr & signable_e) ) + { + gg_assign(value, gg_abs(value)); + } + + if( check_for_error && dest->data.digits ) + { + // We need to see if value can fit into destref + + // We do this by comparing value to 10^(lhs.ldigits + rhs_rdigits) + // Example: rhs is 123.45, whichis 12345 with rdigits 2 + // lhs is 99.999. So, lhs.digits is 5, and lhs.rdigits is 3. + // 10^(5 - 3 + 2) is 10^4, which is 10000. Because 12345 is >= 10000, the + // source can't fit into the destination. + + tree abs_value = gg_define_variable(TREE_TYPE(value)); + gg_assign(abs_value, gg_abs(value)); + + tree power_of_ten = gg_define_variable(INT128); + gg_assign(power_of_ten, + gg_call_expr(INT128, + "__gg__power_of_ten", + gg_add(build_int_cst_type(INT, + dest->data.digits + - dest->data.rdigits), + gg_cast(INT, rhs_rdigits)), + NULL_TREE)); + + IF( gg_cast(INT128, abs_value), + ge_op, + power_of_ten ) + { + // Flag the size error + gg_assign(size_error, integer_one_node); + } + ELSE + ENDIF + } + scale_by_power_of_ten(value, + gg_subtract(build_int_cst_type(INT, dest->data.rdigits), + gg_cast(INT, rhs_rdigits))); + + // Create a variable of our target type. tree target = gg_define_variable(dest_type); // Cast the source to the target gg_assign(target, gg_cast(dest_type, value)); + if( check_for_error && !dest->data.digits ) + { + // The destination is pure binary. Make sure we fit: + int nbytes = gg_sizeof(dest_type); + // We are making sure that value is less than the power of two + FIXED_WIDE_INT(128) power_of_two = get_power_of_two(nbytes); + tree p_of_two = wide_int_to_tree(value_type, power_of_two); + + IF( value, ge_op, p_of_two ) + { + // Flag the size error + gg_assign(size_error, gg_bitwise_or(size_error, integer_one_node)); + } + ELSE + { + } + ENDIF + } + tree dest_pointer = gg_define_variable(UCHAR_P); gg_assign(dest_pointer, gg_add(member(dest->var_decl_node, "data"), dest_offset)); @@ -1855,6 +1987,14 @@ mh_to_binary( const cbl_refer_t &destref, // This routine moves a numeric value to a binary destination. The dest // can be little-endian or big-endian. + /* In July of 2026, I attempted to create GENERIC for moving intermediates + to binaries. It's here, and it can be activated by commenting out the + line + && !(sourceref.field->attr & (intermediate_e )) + But it runs slower than the library version. I didn't attempt to figure + out why that is (other things to do!) so I still have the code here. But + it isn't being used. Dubner, 2026-07-22 */ + bool moved = false; cbl_figconst_t figconst = cbl_figconst_of( sourceref.field->data.original()); @@ -1908,21 +2048,36 @@ mh_to_binary( const cbl_refer_t &destref, destref.field->data.rdigits, check_for_error, size_error); - moved = true; } else { - tree source_type = tree_type_from_refer(sourceref); - tree source; - get_binary_value(source, sourceref, source_type); - copy_native_into_place(destref.field, - refer_offset(destref), - source, - sourceref.field->data.rdigits, - check_for_error, - size_error); - moved = true; + if( sourceref.field->attr & intermediate_e ) + { + tree source_type = tree_type_from_refer(sourceref); + tree source; + get_binary_value(source, sourceref, source_type); + copy_intermediate_into_place( destref.field, + refer_offset(destref), + source, + member(sourceref.field->var_decl_node, + "rdigits"), + check_for_error, + size_error); + } + else + { + tree source_type = tree_type_from_refer(sourceref); + tree source; + get_binary_value(source, sourceref, source_type); + copy_native_into_place( destref.field, + refer_offset(destref), + source, + sourceref.field->data.rdigits, + check_for_error, + size_error); + } } + moved = true; } return moved; } @@ -3445,7 +3600,7 @@ move_helper(tree size_error, // This is an INT moved = mh_to_binary( destref, sourceref, tsource, - restore_on_error, + check_for_error, size_error); } @@ -3560,7 +3715,7 @@ move_helper(tree size_error, // This is an INT { IF(size_error, ne_op, integer_zero_node) { - // We had a size error, but there was no restore_on_error. Pointer + // We had a size error, but there was no restore_on_error. // Let our lord and master know there was a truncation: set_exception_code(ec_size_truncation_e); } diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index e03403f64a9..7599c99ec68 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -5905,62 +5905,38 @@ accept_body: ACCEPT scalar[r] { statement_begin(@1, ACCEPT); $$.func = accept_done_e; - if( $r->is_reference() ) { - error_msg(@1, "subscripts are unsupported here"); - YYERROR; - } - parser_accept_date_yymmdd($r->field); + parser_accept_date_yymmdd(*$r); } | ACCEPT scalar[r] FROM DATE YYYYMMDD { statement_begin(@1, ACCEPT); $$.func = accept_done_e; - if( $r->is_reference() ) { - error_msg(@1, "subscripts are unsupported here"); - YYERROR; - } - parser_accept_date_yyyymmdd($r->field); + parser_accept_date_yyyymmdd(*$r); } | ACCEPT scalar[r] FROM DAY { statement_begin(@1, ACCEPT); $$.func = accept_done_e; - if( $r->is_reference() ) { - error_msg(@1, "subscripts are unsupported here"); - YYERROR; - } - parser_accept_date_yyddd($r->field); + parser_accept_date_yyddd(*$r); } | ACCEPT scalar[r] FROM DAY YYYYDDD { statement_begin(@1, ACCEPT); $$.func = accept_done_e; - if( $r->is_reference() ) { - error_msg(@1, "subscripts are unsupported here"); - YYERROR; - } - parser_accept_date_yyyyddd($r->field); + parser_accept_date_yyyyddd(*$r); } | ACCEPT scalar[r] FROM DAY_OF_WEEK { statement_begin(@1, ACCEPT); $$.func = accept_done_e; - if( $r->is_reference() ) { - error_msg(@1, "subscripts are unsupported here"); - YYERROR; - } - parser_accept_date_dow($r->field); + parser_accept_date_dow(*$r); } | ACCEPT scalar[r] FROM TIME { statement_begin(@1, ACCEPT); $$.func = accept_done_e; - if( $r->is_reference() ) { - error_msg(@1, "subscripts are unsupported here"); - YYERROR; - } - parser_accept_date_hhmmssff($r->field); + parser_accept_date_hhmmssff(*$r); } | ACCEPT scalar[r] FROM acceptable { @@ -10157,6 +10133,8 @@ filename: NAME | device_name[dev] { auto dev = symbol_special($dev.id); + error_msg(@dev, "invalid device %qs: FD name required", dev->name); + YYERROR; auto e = symbol_file(PROGRAM, dev->name); if( ! e ) { error_msg(@dev, "no FD selected for device '%s'", dev->name); diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index 1416c189bf4..ffd68106640 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -2493,29 +2493,29 @@ symbol_table_init(void) { **/ static cbl_field_t debug_registers[] = { - { FldGroup, register_e, + { FldGroup, external_e|register_e, {132,132,0,0, NULL}, 1, "DEBUG-ITEM", cp1252 }, - { FldAlphanumeric, register_e, + { FldAlphanumeric, external_e|register_e, {6,6,0,0, " "}, 2, "DEBUG-LINE", cp1252 }, - { FldAlphanumeric, register_e|filler_e, + { FldAlphanumeric, external_e|register_e|filler_e, {1,1,0,0, " "}, 2, "FILLER", cp1252 }, - { FldAlphanumeric, register_e, + { FldAlphanumeric, external_e|register_e, {30,30,0,0, NULL}, 2, "DEBUG-NAME", cp1252 }, - { FldAlphanumeric, register_e|filler_e, + { FldAlphanumeric, external_e|register_e|filler_e, {1,1,0,0, " "}, 2, "FILLER", cp1252 }, - { FldNumericDisplay, signable_e | register_e | leading_e | separate_e, + { FldNumericDisplay, signable_e | external_e|register_e | leading_e | separate_e, {5,5,4,0, NULL}, 2, "DEBUG-SUB-1", cp1252 }, - { FldAlphanumeric, register_e|filler_e, + { FldAlphanumeric, external_e|register_e|filler_e, {1,1,0,0, " "}, 2, "FILLER", cp1252 }, - { FldNumericDisplay, signable_e | register_e | leading_e | separate_e, + { FldNumericDisplay, signable_e | external_e|register_e | leading_e | separate_e, {5,5,4,0, NULL}, 2, "DEBUG-SUB-2", cp1252 }, - { FldAlphanumeric, register_e|filler_e, + { FldAlphanumeric, external_e|register_e|filler_e, {1,1,0,0, " "}, 2, "FILLER", cp1252 }, - { FldNumericDisplay, signable_e | register_e | leading_e | separate_e, + { FldNumericDisplay, signable_e | external_e|register_e | leading_e | separate_e, {5,5,4,0, NULL}, 2, "DEBUG-SUB-3", cp1252 }, - { FldAlphanumeric, register_e | filler_e, + { FldAlphanumeric, external_e|register_e | filler_e, {1,1,0,0, " "}, 2, "FILLER", cp1252 }, - { FldAlphanumeric, register_e, + { FldAlphanumeric, external_e|register_e, {76,76,0,0, NULL}, 2, "DEBUG-CONTENTS", cp1252 }, }; @@ -3709,7 +3709,7 @@ new_temporary_impl( enum cbl_field_type_t type, const cbl_name_t name = nullptr static const struct cbl_field_t empty_comp5 = { FldNumericBin5, signable_e | intermediate_e, - {16, 16, MAX_FIXED_POINT_DIGITS, 0, NULL} }; + {16, 16, 0, 0, NULL} }; static const struct cbl_field_t empty_conditional = { FldConditional, intermediate_e, cbl_field_data_t{} }; static struct cbl_field_t empty_literal = { diff --git a/gcc/cobol/symfind.cc b/gcc/cobol/symfind.cc index 6c3d06cc1a6..20d44170832 100644 --- a/gcc/cobol/symfind.cc +++ b/gcc/cobol/symfind.cc @@ -53,7 +53,7 @@ extern int yydebug; */ struct funcname { std::string output; - funcname( const char name[] ) { + funcname( const char name[] ) { // cppcheck-suppress noExplicitConstructor auto ename = name + strlen(name); auto p = std::find(name, ename, ' '); p = p == ename? name : p + 1; diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc index 46d1d1875a7..a385a6c9a77 100644 --- a/gcc/cobol/util.cc +++ b/gcc/cobol/util.cc @@ -561,7 +561,6 @@ determine_intermediate_type( const cbl_refer_t& aref, { output.type = FldNumericBin5; output.data.capacity(16); - output.data.digits = MAX_FIXED_POINT_DIGITS; output.attr = (intermediate_e | signable_e ); } diff --git a/gcc/testsuite/cobol.dg/group2/ACCEPT_FROM__date__with_subscripts_and_refmods.cob b/gcc/testsuite/cobol.dg/group2/ACCEPT_FROM__date__with_subscripts_and_refmods.cob new file mode 100644 index 00000000000..a5d24282f6f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ACCEPT_FROM__date__with_subscripts_and_refmods.cob @@ -0,0 +1,30 @@ + *> Do not edit this generated file. See README.txt + *> { dg-do run } + *> { dg-output-file "group2/ACCEPT_FROM__date__with_subscripts_and_refmods.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 01 dates. + 02 foo pic x(30) occurs 6 times. + 01 msg pic x(20) value "The year is xxxx CE." . + procedure division. + display "GCOBOL_CURRENT_DATE" upon environment-name + display "19530227123456" upon environment-value + accept foo(1) from time + accept foo(2) from date + accept foo(3) from date yyyymmdd + accept foo(4) from day + accept foo(5) from day yyyyddd + accept foo(6) from day-of-week + display function trim(foo(1)) + display function trim(foo(2)) + display function trim(foo(3)) + display function trim(foo(4)) + display function trim(foo(5)) + display function trim(foo(6)) + accept msg(13:4) from date yyyymmdd + display msg + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/ACCEPT_FROM__date__with_subscripts_and_refmods.out b/gcc/testsuite/cobol.dg/group2/ACCEPT_FROM__date__with_subscripts_and_refmods.out new file mode 100644 index 00000000000..ce6d42c3a89 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ACCEPT_FROM__date__with_subscripts_and_refmods.out @@ -0,0 +1,8 @@ +12345600 +530227 +19530227 +53058 +1953058 +5 +The year is 1953 CE. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE__identical__operations.cob b/gcc/testsuite/cobol.dg/group2/MOVE__identical__operations.cob new file mode 100644 index 00000000000..8da0a45b693 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE__identical__operations.cob @@ -0,0 +1,34 @@ + *> Do not edit this generated file. See README.txt + *> { dg-do run } + *> { dg-output-file "group2/MOVE__identical__operations.out" } + program-id. bugger. + data division. + working-storage section. + 01 debug-contents-e pic x(76) external. + 01 debug-contents-b pic x(76) based . + 01 debug-contents-w pic x(76) . + procedure division. + allocate debug-contents-b. + move "telephone-1" to debug-contents + move debug-contents to debug-contents-b + move debug-contents-b to debug-contents-e + move debug-contents-e to debug-contents-w + display "start with " function trim(debug-contents-e) + call "bug" using debug-contents-w + display "end with " function trim(debug-contents-e) + goback. + end program bugger. + *> + program-id. bug. + data division. + working-storage section. + 01 debug-contents-e pic x(76) external. + 01 debug-contents-w2 pic x(76). + linkage section. + 01 dc. + 10 debug-contents-l pic x(76). + procedure division using dc. + move debug-contents-l to debug-contents-w2 + string function trim(debug-contents-w2) " - modified" into debug-contents-e + goback. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE__identical__operations.out b/gcc/testsuite/cobol.dg/group2/MOVE__identical__operations.out new file mode 100644 index 00000000000..0989c567251 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE__identical__operations.out @@ -0,0 +1,3 @@ +start with telephone-1 +end with telephone-1 - modified + diff --git a/gcc/testsuite/cobol.dg/group2/RT3574_PR__40-_Repository_section_intrinsic_funcs.cob b/gcc/testsuite/cobol.dg/group2/RT3574_PR__40-_Repository_section_intrinsic_funcs.cob new file mode 100644 index 00000000000..9b85fbf13ab --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/RT3574_PR__40-_Repository_section_intrinsic_funcs.cob @@ -0,0 +1,15 @@ + *> Do not edit this generated file. See README.txt + *> { dg-do run } + *> { dg-options "-ffixed-form -copyext copy -I." } + + >>source format is free + IDENTIFICATION DIVISION. + PROGRAM-ID. fail. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + REPOSITORY. + FUNCTION LENGTH TRIM INTRINSIC. + PROCEDURE DIVISION. + DISPLAY "HELLO WORLD.". + END PROGRAM fail. + diff --git a/libgcobol/constants.cc b/libgcobol/constants.cc index 51cd5bdfff0..0d97aeff6e8 100644 --- a/libgcobol/constants.cc +++ b/libgcobol/constants.cc @@ -421,7 +421,7 @@ struct cblc_field_t __ggsr__debug_item = { .parent = NULL , .occurs_lower = 0 , .occurs_upper = 0 , - .attr = register_e , + .attr = external_e | register_e , .type = FldGroup , .level = 01 , .digits = 0 , @@ -442,7 +442,7 @@ struct cblc_field_t __ggsr__debug_line = { .parent = &__ggsr__debug_item , .occurs_lower = 0 , .occurs_upper = 0 , - .attr = register_e , + .attr = external_e | register_e , .type = FldAlphanumeric , .level = 05 , .digits = 0 , @@ -464,7 +464,7 @@ struct cblc_field_t __ggsr__debug_filler_1 = { .parent = &__ggsr__debug_item , .occurs_lower = 0 , .occurs_upper = 0 , - .attr = register_e | filler_e , + .attr = external_e | register_e | filler_e , .type = FldAlphanumeric , .level = 05 , .digits = 0 , @@ -485,7 +485,7 @@ struct cblc_field_t __ggsr__debug_name = { .parent = &__ggsr__debug_item , .occurs_lower = 0 , .occurs_upper = 0 , - .attr = register_e , + .attr = external_e | register_e , .type = FldAlphanumeric , .level = 05 , .digits = 0 , @@ -506,7 +506,7 @@ struct cblc_field_t __ggsr__debug_filler_2 = { .parent = &__ggsr__debug_item , .occurs_lower = 0 , .occurs_upper = 0 , - .attr = register_e | filler_e , + .attr = external_e | register_e | filler_e , .type = FldAlphanumeric , .level = 05 , .digits = 0 , @@ -527,7 +527,7 @@ struct cblc_field_t __ggsr__debug_sub_1 = { .parent = &__ggsr__debug_item , .occurs_lower = 0 , .occurs_upper = 0 , - .attr = signable_e | register_e | leading_e | separate_e , + .attr = signable_e | external_e | register_e | leading_e | separate_e , .type = FldNumericDisplay , .level = 05 , .digits = 4 , diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc index a4a88238002..ba421cee2cf 100644 --- a/libgcobol/libgcobol.cc +++ b/libgcobol/libgcobol.cc @@ -239,6 +239,10 @@ static const char *last_exception_paragraph; static const char *last_exception_source_file; static int last_exception_line_number; static const char *last_exception_statement; +// last_exception_call is a special case. It gets set immediately before the +// default_exception_handler is invoked, so it's followed immediately by an +// abort(). +static const char *last_exception_call; // These variables are similar, and are established when an exception is // raised for a file I-O operation. static cblc_file_prior_op_t last_exception_file_operation; @@ -2494,21 +2498,29 @@ __gg__field_from_string(cblc_field_t *field, } static void -field_from_ascii(cblc_field_t *field, char *psz) +field_from_ascii(cblc_field_t *field, + size_t offset, + size_t length, + char *psz) { cblc_field_t source = {}; source.type = FldAlphanumeric; source.capacity = strlen(psz); source.data = as_unsigned_chars(psz); source.encoding = __gg__console_encoding; - __gg__move( field, field->offset, field->capacity, - &source, source.offset, source.capacity, - 0, truncation_e ); + __gg__move( field, + offset, + length, + &source, + source.offset, + source.capacity, + 0, + truncation_e ); } extern "C" void -__gg__get_date_yymmdd(cblc_field_t *field) +__gg__get_date_yymmdd(cblc_field_t *field, size_t offset, size_t length) { char ach[32]; @@ -2520,12 +2532,12 @@ __gg__get_date_yymmdd(cblc_field_t *field) local->tm_year % 100, local->tm_mon+1 % 100, local->tm_mday % 100 ); - field_from_ascii(field, ach); + field_from_ascii(field, offset, length, ach); } extern "C" void -__gg__get_date_yyyymmdd(cblc_field_t *field) +__gg__get_date_yyyymmdd(cblc_field_t *field, size_t offset, size_t length) { char ach[32]; time_t t = cobol_time(); @@ -2535,12 +2547,12 @@ __gg__get_date_yyyymmdd(cblc_field_t *field) local->tm_year + 1900, local->tm_mon+1, local->tm_mday); - field_from_ascii(field, ach); + field_from_ascii(field, offset, length, ach); } extern "C" void -__gg__get_date_yyddd(cblc_field_t *field) +__gg__get_date_yyddd(cblc_field_t *field, size_t offset, size_t length) { char ach[32]; @@ -2551,12 +2563,12 @@ __gg__get_date_yyddd(cblc_field_t *field) "%2.2d%3.3d", local->tm_year % 100, local->tm_yday+1); - field_from_ascii(field, ach); + field_from_ascii(field, offset, length, ach); } extern "C" void -__gg__get_yyyyddd(cblc_field_t *field) +__gg__get_yyyyddd(cblc_field_t *field, size_t offset, size_t length) { char ach[32]; @@ -2567,12 +2579,12 @@ __gg__get_yyyyddd(cblc_field_t *field) "%4.4d%3.3d", local->tm_year + 1900, local->tm_yday+1); - field_from_ascii(field, ach); + field_from_ascii(field, offset, length, ach); } extern "C" void -__gg__get_date_dow(cblc_field_t *field) +__gg__get_date_dow(cblc_field_t *field, size_t offset, size_t length) { char ach[32]; @@ -2582,7 +2594,7 @@ __gg__get_date_dow(cblc_field_t *field) sprintf(ach, "%1.1d", local->tm_wday == 0 ? 7 : local->tm_wday); - field_from_ascii(field, ach); + field_from_ascii(field, offset, length, ach); } static int @@ -2682,7 +2694,7 @@ __gg__clock_gettime(struct cbl_timespec *tp) extern "C" void -__gg__get_date_hhmmssff(cblc_field_t *field) +__gg__get_date_hhmmssff(cblc_field_t *field, size_t offset, size_t length) { char ach[32]; struct cbl_timespec tv; @@ -2705,7 +2717,7 @@ __gg__get_date_hhmmssff(cblc_field_t *field) tm.tm_min, tm.tm_sec, hundredths); - field_from_ascii(field, ach); + field_from_ascii(field, offset, length, ach); } static @@ -3528,7 +3540,7 @@ format_for_display_internal(char **dest, const unsigned char *digits_e; // This is the running index into our output destination. int index = 0; - bool is_negative; + bool is_negative=false; switch(signtype) { @@ -10533,6 +10545,21 @@ default_exception_handler( ec_type_t ec ) assert( ec_status.is_enabled(ec) ); } + if( !filename && last_exception_call) { + char *callname = strdup(last_exception_call); + massert(callname); + char *p = callname+strlen(callname)-1; + while(p >= callname) + { + if( *p != ascii_space ) + { + break; + } + *p-- = '\0'; + } + filename = callname; + } + switch( disposition ) { case ec_category_none_e: case uc_category_none_e: @@ -11178,6 +11205,7 @@ __gg__set_exception_code(ec_type_t ec, int from_raise_statement) last_exception_paragraph = NULL ; last_exception_source_file = NULL ; last_exception_line_number = 0 ; + last_exception_call = NULL ; last_exception_statement = NULL ; last_exception_file_operation = file_op_none ; last_exception_file_status = FsSuccess ; @@ -14082,3 +14110,20 @@ __gg__compare_binary_to_string( int *result, return; } +extern "C" +void +__gg__set_exception_call(const cblc_field_t *field, + size_t offset) + { + size_t nbytes; + cbl_encoding_t enc = field->encoding; + if( field->encoding == custom_encoding_e) + { + enc = DEFAULT_SOURCE_ENCODING; + } + last_exception_call = __gg__miconverter(enc, + DEFAULT_SOURCE_ENCODING, + field->data + offset, + field->capacity, + &nbytes); + }