https://gcc.gnu.org/g:92160cfbed4861f7bc6c16d67ac74e1649e2fd04
commit r17-5523-g92160cfbed4861f7bc6c16d67ac74e1649e2fd04 Author: James K. Lowden <[email protected]> Date: Fri Oct 23 17:07:06 2026 -0400 cobol: Problem report answers. Fix RT 3671, COMP-3 requires PICTURE, not caught in parser. Fix RT 3674 Reject arithmetic INDEX operands.j Fix RT 3692, MOVE PIC PPP999 TO ALPHANUMERIC should be a syntax error. Fix RT 3709, numeric literal doesn't behave as integer, just float. Fix RT 3719, allow program and paragraph with same name. gcc/cobol/ChangeLog: * parse.y: Require PICTURE for PACKED-DECIMAL. * parse_ante.h (struct arith_t): Allow +/- for INDEX type. (valid_operands): Remove function. (parser_move_carefully): Refine diagnostic. * scan_ante.h (typed_name): Set is_float member. * symbols.cc (symbol_program_add): Return NULL only if program exists. * util.cc (valid_move): Reject fractional MOVE to alphanumeric. Diff: --- gcc/cobol/parse.y | 8 +++-- gcc/cobol/parse_ante.h | 96 +++++++++++++++++++++++++++++--------------------- gcc/cobol/scan_ante.h | 4 +++ gcc/cobol/symbols.cc | 4 ++- gcc/cobol/util.cc | 13 +++++++ 5 files changed, 81 insertions(+), 44 deletions(-) diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index 18cf8374fea2..f14547c2070f 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -4500,6 +4500,10 @@ data_descr1: level_name // Set Packed-Decimal capacity if( $field->type == FldPacked ) { + if( ! ($data_clauses & picture_clause_e) ) { + error_msg(@field, "%qs requires PICTURE clause", + cbl_field_type_name($field->type)); + } // COMP-6 is like COMP-3 but with no sign nybble. The // code in type_capacity assumes a sign nybble. auto one_less = $field->has_attr(separate_e) ? 1 : 0; @@ -13933,7 +13937,7 @@ ast_relop( const cbl_loc_t& loc, cbl_field_t *tgt, static void ast_add( arith_t *arith ) { - arith->numeric_ok(); + arith->numeric_ok(true); size_t nC = arith->tgts.size(), nA = arith->A.size(); std::vector <cbl_num_result_t> C(nC); cbl_num_result_t *pC; @@ -13951,7 +13955,7 @@ ast_add( arith_t *arith ) { static bool ast_subtract( arith_t *arith ) { - arith->numeric_ok(); + arith->numeric_ok(true); size_t nC = arith->tgts.size(), nA = arith->A.size(), nB = arith->B.size(); std::vector <cbl_refer_t> A(nA); std::vector <cbl_refer_t> B(nB); diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h index db624c78128b..70d63b928dd8 100644 --- a/gcc/cobol/parse_ante.h +++ b/gcc/cobol/parse_ante.h @@ -638,35 +638,45 @@ struct arith_t { return "???"; } - void numeric_ok() { - are_numeric(locs.A, A); - are_numeric(locs.B, B); - are_numeric(locs.tgts, tgts); - is_numeric(locs.remainder, cbl_num_result_t{prohibited_e,remainder}); + void numeric_ok( bool index_acceptable = false ) { + are_numeric(locs.A, A, false); + are_numeric(locs.B, B, index_acceptable); + are_numeric(locs.tgts, tgts, index_acceptable); + is_numeric(locs.remainder, cbl_num_result_t{prohibited_e,remainder}, false); } protected: - static bool is_numeric( const cbl_loc_t& loc, const cbl_refer_t& r ) { - if( r.field && ! ::is_numeric(r.field) ) { - if( r.field->type != FldInvalid ) { - error_msg(loc, "%qs (%s) is not numeric", - nice_name_of(r.field), - cbl_field_type_name(r.field->type)); + static bool is_numeric( const cbl_loc_t& loc, + const cbl_refer_t& r, bool index_acceptable ) { + if( r.field ) { + bool operand_ok = ::is_numeric(r.field); + + if( operand_ok && r.field->type == FldIndex ) { + operand_ok = index_acceptable; + } + + if( ! operand_ok ) { + if( r.field->type != FldInvalid ) { + error_msg(loc, "%qs (%s) is not numeric", + nice_name_of(r.field), + cbl_field_type_name(r.field->type)); + } + return false; } - return false; } return true; } - static bool is_numeric( const cbl_loc_t& loc, const cbl_num_result_t& res ) { + static bool is_numeric( const cbl_loc_t& loc, + const cbl_num_result_t& res, bool index_acceptable ) { // only targets have rounding, and may be numeric-edited bool edited = res.refer.field && res.refer.field->type == FldNumericEdited; - return edited || is_numeric( loc, res.refer ); + return edited || is_numeric( loc, res.refer, index_acceptable ); } template <typename T> - static bool are_numeric( const cbl_loc_t& loc, const T& args ) { + static bool are_numeric( const cbl_loc_t& loc, const T& args, bool index_acceptable ) { bool ok = true; for (const auto& elem : args) { - ok = ok && is_numeric(loc, elem); + ok = ok && is_numeric(loc, elem, index_acceptable); } return ok; } @@ -3678,11 +3688,6 @@ parser_subtract2( const cbl_num_result_t& to, parser_subtract(to.refer, to.refer, from, to.rounded); } -static bool -valid_operands( const cbl_refer_t& src, const cbl_refer_t& tgt ) { - return ! (src.field->type == FldInvalid || tgt.field->type == FldInvalid); -} - static bool parser_move_carefully( const char */*F*/, int /*L*/, tgt_list_t *tgt_list, @@ -3697,29 +3702,38 @@ parser_move_carefully( const char */*F*/, int /*L*/, return false; } - if( valid_operands(src, tgt) ) { - if( is_index ) { - if( tgt.field->type != FldIndex && src.field->type != FldIndex) { - auto msg = xasprintf("invalid SET %s (%s) TO %s (%s): not a field index", - name_of(tgt.field), cbl_field_type_name(tgt.field->type), - name_of(src.field), cbl_field_type_name(src.field->type)); - dialect_ok(src.loc, MfSetNumeric, msg); - free(msg); - } - } else { - if( ! valid_move( tgt.field, src.field ) ) { - if( src.field->type == FldPointer && - tgt.field->type == FldPointer ) { - dialect_ok(src.loc, MfMovePointer, "MOVE POINTER"); - } else { - error_msg(src.loc, "cannot MOVE %qs (%s) TO %qs (%s)", - nice_name_of(src.field), cbl_field_type_name(src.field->type), - nice_name_of(tgt.field), cbl_field_type_name(tgt.field->type)); - } + // Neither operand is FldInvalid. + if( is_index ) { // index move + if( tgt.field->type != FldIndex && src.field->type != FldIndex) { + auto msg = xasprintf("invalid SET %s (%s) TO %s (%s): not a field index", + name_of(tgt.field), cbl_field_type_name(tgt.field->type), + name_of(src.field), cbl_field_type_name(src.field->type)); + dialect_ok(src.loc, MfSetNumeric, msg); + free(msg); + } + } else { + if( ! valid_move( tgt.field, src.field ) ) { + if( src.field->type == FldPointer && + tgt.field->type == FldPointer ) { + dialect_ok(src.loc, MfMovePointer, "MOVE POINTER"); + } else { + // other invalid move + const char * src_type = src.field->type == FldInvalid? + "undefined" : cbl_field_type_name(src.field->type); + const char * tgt_type = tgt.field->type == FldInvalid? + "undefined" : cbl_field_type_name(tgt.field->type); + + if( 0 < src.field->data.rdigits ) src_type = "non-integer"; + if( 0 < src.field->has_attr(all_alpha_e) ) src_type = "ALPHABETIC"; + + error_msg(src.loc, "cannot MOVE %qs (%s) TO %qs (%s)", + nice_name_of(src.field), src_type, + nice_name_of(tgt.field), tgt_type); } } } - } + } // end target list + size_t ntgt = tgt_list->targets.size(); std::vector <cbl_refer_t> tgts(ntgt); std::transform( tgt_list->targets.begin(), tgt_list->targets.end(), tgts.begin(), diff --git a/gcc/cobol/scan_ante.h b/gcc/cobol/scan_ante.h index 00ea991cbd34..dd77268b8a18 100644 --- a/gcc/cobol/scan_ante.h +++ b/gcc/cobol/scan_ante.h @@ -875,6 +875,10 @@ typed_name( const char name[] ) { yylval.numstr.radix = f->has_attr(hex_encoded_e)? hexadecimal_e : decimal_e; yylval.numstr.string = xstrdup(f->data.original()); + const auto estring = yylval.numstr.string + strlen(yylval.numstr.string); + yylval.numstr.is_float = ! std::all_of(yylval.numstr.string, + estring, + fisdigit); return NUMSTR; } if( !f->has_attr(record_key_e) ) { // not a key-name literal diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index ffa24cbc7b49..20467e72087c 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -4707,7 +4707,9 @@ symbol_program_add( size_t program, cbl_label_t *input ) if( program == elem.program ) { auto L = cbl_label_of(&elem); if( ! L->prototype ) { // prototypes don't count - return 0 == strcasecmp(name, L->name); + if( L->type == LblProgram ) { + return 0 == strcasecmp(name, L->name); + } } } } diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc index 6196671d446f..b1944f4d7865 100644 --- a/gcc/cobol/util.cc +++ b/gcc/cobol/util.cc @@ -2366,6 +2366,19 @@ valid_move( const cbl_refer_t& tgt_ref, const cbl_refer_t& src_ref ) assert(tgt->type < sizeof(matrix[0])); assert(src->type < sizeof(matrix[0])); + if( tgt->type != FldGroup ) { + if( ! is_numericish(effective_type(tgt_ref)) ) { + if( is_numeric(effective_type(src_ref)) ) { + if( 0 < src_ref.field->data.rdigits ) { + dbgmsg("%s:%d: src not integer %s, %s rdigits=%d", __func__, __LINE__, + cbl_field_type_str(src->type), cbl_field_type_str(tgt->type), + src_ref.field->data.rdigits); + dbgmsg("%s:%d: %s", __func__, __LINE__, field_str(src)); + return false; + } + } + } + } /* * 8.4.3.3.3 Syntax rules * A refmod may apply to:
