From 203cbbc22fd8c8ffbc29eb846d8901e4346e95f8 Mon Sep 17 00:00:00 2001 From: Robert Dubner Date: Thu, 5 Feb 2026 10:45:40 -0500 Subject: [PATCH] cobol: Use _perform_line_pairs instead of injecting encoded label names. The gcobol front end has been communicating with GDB-COBOL by encoding information into labels that are injected into the assembly language with ASM_EXPR nodes. That behavior is, at best, questionable. These changes replace the "proccall" and "procret" types of those labels in favor of a static _perform_line_pairs table that contains the same information and is accessible by GDB-COBOL by virtue of its known name. That table allows GDB-COBOL to "NEXT over COBOL PERFORM" statements in a way that is familiar to users who have used "NEXT over function call". Eventually that information should find its way into the .debug_info section, but at the present time I don't know how to do that on either the compiler or debugger sides. Most of these changes involve eliminating gg_insert_into_assembler calls and replacing them with the perform_is_armed/perform_line_pairs logic. Some COBOL variable initialization changes crept in here, as well. gcc/cobol/ChangeLog: * genapi.cc (DEFAULT_LINE_NUMBER): Remove unused #define. (parser_statement_begin): Implement perform_is_armed logic. (initialize_variable_internal): Handle both real and int types in SHOW_PARSE tracing. (section_label): Comment a renumbered insert_nop() for gdb-cobol logic. (paragraph_label): Likewise. (leave_procedure): Eliminate call to gg_insert_into_assembler(). (parser_enter_section): Renumber insert_nop(). (parser_perform): Eliminate call to gg_insert_into_assembler(). (parser_perform_times): Likewise. (internal_perform_through): Likewise. (internal_perform_through_times): Likewise. (parser_leave_file): Create the static _perform_line_pairs table. (parser_sleep): Renumber insert_nop(). (parser_division): Remove calls to initialize_the_data(). (parser_perform_start): New call to insert_nop(). (parser_perform_conditional): Likewise. (perform_outofline_before_until): Expanded comment. (perform_outofline_after_until): Eliminate call to gg_insert_into_assembler(). (perform_outofline_testafter_varying): Likewise. (perform_outofline_before_varying): Likewise. (perform_inline_testbefore_varying): New call to insert_nop(). (create_and_call): Change a comment. * gengen.cc (gg_create_goto_pair): Change characteristics of a label. * parse.y: Change how data are initialized. * parse_ante.h (field_type_update): Likewise. * symbols.cc (cbl_field_t::set_signable): Likewise. (cbl_field_t::encode): Likewise. * symbols.h (struct cbl_field_t): Likewise. * util.cc (symbol_field_type_update): Likewise. (cbl_field_t::encode_numeric): Likewise. libgcobol/ChangeLog: * valconv.cc (__gg__string_to_numeric_edited): Explanatory comment. --- gcc/cobol/genapi.cc | 227 ++++++++++++++++++++--------------------- gcc/cobol/gengen.cc | 4 + gcc/cobol/parse.y | 78 +++++++++----- gcc/cobol/parse_ante.h | 11 +- gcc/cobol/symbols.cc | 47 ++++++++- gcc/cobol/symbols.h | 1 + gcc/cobol/util.cc | 34 ++++-- libgcobol/valconv.cc | 8 +- 8 files changed, 250 insertions(+), 160 deletions(-) diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index fac689e3f67..40be939dd72 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -72,8 +72,6 @@ static tree label_list_back_label; static void hijack_for_development(const char *funcname); static size_t sv_data_name_counter = 1; -static int call_counter = 1; -static int pseudo_label = 1; static bool suppress_cobol_entry_point = false; static char ach_cobol_entry_point[256] = ""; @@ -84,7 +82,8 @@ int show_parse_indent = 0; static bool sv_is_i_o = false; -#define DEFAULT_LINE_NUMBER 2 +static int perform_is_armed = 0; +static std::map perform_line_pairs; #ifdef LINE_TICK /* This code is used from time to time when sorting out why compilation @@ -1151,6 +1150,18 @@ parser_statement_begin( const cbl_name_t statement_name, gcc_assert( gg_trans_unit.function_stack.size() ); + // If a PERFORM is armed, that's the line that the PERFORM is on. The + // cobol_location().first_line here is the major statement following the + // the PERFORM statement. (We don't use .loc information in GDB because of + // the difficulty in teasing out which is the "primary" .loc from the + // 'is_stmt' and 'discriminator'. If that's possible, I haven't yet figured + // how.) + if( perform_is_armed ) + { + perform_line_pairs[perform_is_armed] = cobol_location().first_line; + perform_is_armed = 0; + } + // 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 @@ -1314,14 +1325,22 @@ initialize_variable_internal( cbl_refer_t refer, default: { char ach[128]; - real_to_decimal (ach, - TREE_REAL_CST_PTR (parsed_var->data.value_of()), - sizeof(ach), 16, 0); + if( TREE_CODE(TREE_TYPE(parsed_var->data.value_of())) == REAL_TYPE) + { + real_to_decimal (ach, + TREE_REAL_CST_PTR (parsed_var->data.value_of()), + sizeof(ach), 16, 0); + } + else + { + wi::tree_to_wide_ref iii = + wi::to_wide( parsed_var->data.value_of() ); + print_dec(iii, ach, SIGNED); + } SHOW_PARSE_TEXT(ach); break; } } - } SHOW_PARSE_TEXT("<<") } @@ -2464,7 +2483,8 @@ section_label(struct cbl_proc_t *procedure) } assembler_label(psz2); free(psz2); - insert_nop(108); + // Needed so that GDB-COBOL can trap at a section name. + insert_nop(101); } static void @@ -2537,7 +2557,7 @@ paragraph_label(struct cbl_proc_t *procedure) // // Yes, trying to understand this causes headaches for many people who read // this. Take an aspirin. - insert_nop(109); + insert_nop(102); } static void @@ -2631,15 +2651,7 @@ 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 *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); } @@ -2817,7 +2829,7 @@ parser_enter_section(cbl_label_t *label) // This NOP is needed to give GDB a line number for the entry point of // paragraphs - insert_nop(101); + insert_nop(103); struct cbl_proc_t *procedure = find_procedure(label); gg_append_statement(procedure->top.label); @@ -3151,11 +3163,8 @@ parser_perform(cbl_label_t *label, bool suppress_nexting) if( !suppress_nexting ) { - sprintf(ach, - "_proccall." HOST_SIZE_T_PRINT_DEC ".%d:", - (fmt_size_t)symbol_label_id(label), - call_counter++); - gg_insert_into_assembler( ach ); + // Flag this source-code line as being a PERFORM statement. + perform_is_armed = CURRENT_LINE_NUMBER ; } // We do the indirect jump in order to prevent the compiler from complaining @@ -3198,12 +3207,7 @@ parser_perform_times( cbl_label_t *proc_1, cbl_refer_t count ) TRACE1_END } - char ach[256]; - size_t our_pseudo_label = pseudo_label++; - sprintf(ach, - "_proccallb." HOST_SIZE_T_PRINT_DEC ":", - (fmt_size_t)our_pseudo_label); - gg_insert_into_assembler( ach ); + perform_is_armed = CURRENT_LINE_NUMBER ; tree counter = gg_define_variable(LONG); @@ -3221,12 +3225,6 @@ parser_perform_times( cbl_label_t *proc_1, cbl_refer_t count ) gg_decrement(counter); } WEND - - sprintf(ach, - "_procretb." HOST_SIZE_T_PRINT_DEC ":", - (fmt_size_t)our_pseudo_label); - token_location_override(current_location_minus_one()); - gg_insert_into_assembler(ach); } static void @@ -3303,12 +3301,7 @@ internal_perform_through( cbl_label_t *proc_1, if( !suppress_nexting ) { - char ach[256]; - sprintf(ach, - "_proccall." HOST_SIZE_T_PRINT_DEC ".%d:", - (fmt_size_t)symbol_label_id(proc_2), - call_counter++); - gg_insert_into_assembler(ach); + perform_is_armed = CURRENT_LINE_NUMBER ; } gg_append_statement(proc1->top.go_to); @@ -3356,13 +3349,7 @@ internal_perform_through_times( cbl_label_t *proc_1, TRACE1_END } - size_t our_pseudo_label = pseudo_label++; - - char ach[256]; - sprintf(ach, - "_proccallb." HOST_SIZE_T_PRINT_DEC ":", - (fmt_size_t)our_pseudo_label); - gg_insert_into_assembler( ach ); + perform_is_armed = CURRENT_LINE_NUMBER ; tree counter = gg_define_variable(LONG); get_binary_value( counter, @@ -3375,12 +3362,6 @@ internal_perform_through_times( cbl_label_t *proc_1, gg_decrement(counter); } WEND - - sprintf(ach, - "_procretb." HOST_SIZE_T_PRINT_DEC ":", - (fmt_size_t)our_pseudo_label); - token_location_override(current_location_minus_one()); - gg_insert_into_assembler( ach ); } void @@ -3573,6 +3554,41 @@ parser_leave_file() // We are leaving the top-level file, which means this compilation is // done, done, done. + // This is where we create the file-static table of PERFORM/FOLLOWING line + // number pairs so that the GDB-COBOL debugger can know where to "return" + // to after a NEXT is issued on a PERFORM statement. + + // We need to create a file-static static array of 32-bit integers. The + // array is terminated with a {0,0} pair: + tree array_of_int_type = build_array_type_nelts(INT, (perform_line_pairs.size()+1)*2); + tree array_of_int = gg_define_variable( array_of_int_type, + "_perform_line_pairs", + 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_int_type; + TREE_STATIC(constr) = 1; + TREE_CONSTANT(constr) = 1; + + // The first element of the array contains the number of elements to follow + size_t i = 0; + for(auto it : perform_line_pairs) + { + CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr), + build_int_cst_type(SIZE_T, i++), + build_int_cst_type(INT, it.first) ); + CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr), + build_int_cst_type(SIZE_T, i++), + build_int_cst_type(INT, it.second) ); + } + CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr), + build_int_cst_type(SIZE_T, i++), + integer_zero_node ); + CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr), + build_int_cst_type(SIZE_T, i++), + integer_zero_node ); + DECL_INITIAL(array_of_int) = constr; + // 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 @@ -6292,7 +6308,7 @@ void parser_sleep(const 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. - insert_nop(103); + insert_nop(104); } } @@ -7312,12 +7328,10 @@ parser_division(cbl_division_t division, if( division == environment_div_e ) { Analyze(); - initialize_the_data(); } else if( division == procedure_div_e ) { Analyze(); - initialize_the_data(); // Do some symbol table index bookkeeping. current_program_index() is valid // at this point in time: @@ -8270,7 +8284,8 @@ 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); - insert_nop(104); + // Necessary for GDB-COBOL PERFORM processing. + insert_nop(105); } void @@ -8314,6 +8329,9 @@ parser_perform_conditional( struct cbl_perform_tgt_t *tgt ) // The next instructions that the parser will give us are the conditional // calculation, so the first thing that goes down is the condover: + /* The following NOP is needed to make NEXT OVER PERFORM BEFORE/AFTER UNTIL + behaves properly. */ + insert_nop(106); gg_append_statement(tgt->addresses.condover[i].go_to); // And then, of course, we need to be able to jump back here to actually @@ -8373,17 +8391,26 @@ perform_outofline_before_until(struct cbl_perform_tgt_t *tgt, /* TOP: - IF CONDITION 0 - GOTO EXIT - ELSE - EXECUTE BODY - GOTO TOP + GOTO condinto + condback: + IF CONDITION 0 + GOTO EXIT + ELSE + EXECUTE BODY + GOTO TOP EXIT: + + GOTO jumpover + condinto: + + GOTO condback + jumpover: */ create_iline_address_pairs(tgt); // Tag the top of the perform + gg_append_statement(tgt->addresses.top.label); // Go do the conditional calculation: @@ -8394,12 +8421,7 @@ perform_outofline_before_until(struct cbl_perform_tgt_t *tgt, // where to return: gg_append_statement(tgt->addresses.condback[0].label); - char ach[256]; - size_t our_pseudo_label = pseudo_label++; - sprintf(ach, - "_proccallb." HOST_SIZE_T_PRINT_DEC ":", - (fmt_size_t)our_pseudo_label); - gg_insert_into_assembler( ach ); + perform_is_armed = CURRENT_LINE_NUMBER ; parser_if(varys[0].until); { @@ -8419,11 +8441,6 @@ 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." HOST_SIZE_T_PRINT_DEC ":", - (fmt_size_t)our_pseudo_label); - token_location_override(current_location_minus_one()); - gg_insert_into_assembler( ach ); } static void @@ -8441,21 +8458,23 @@ perform_outofline_after_until(struct cbl_perform_tgt_t *tgt, /* TOP: - EXECUTE BODY - IF CONDITION 0 - GOTO EXIT - ELSE - ADD BY_0 to VARYING_0 - GOTO TOP + EXECUTE BODY + GOTO condinto + condback: + IF CONDITION 0 + GOTO EXIT + ELSE + GOTO TOP EXIT: + + GOTO jumpover + condinto: + + GOTO condback + jumpover: */ - char ach[256]; - size_t our_pseudo_label = pseudo_label++; - sprintf(ach, - "_proccallb." HOST_SIZE_T_PRINT_DEC ":", - (fmt_size_t)our_pseudo_label); - gg_insert_into_assembler( ach ); + perform_is_armed = CURRENT_LINE_NUMBER ; create_iline_address_pairs(tgt); @@ -8483,11 +8502,6 @@ perform_outofline_after_until(struct cbl_perform_tgt_t *tgt, parser_fi(); // Label the bottom of the PERFORM gg_append_statement( tgt->addresses.exit.label ); - sprintf(ach, - "_procretb." HOST_SIZE_T_PRINT_DEC ":", - (fmt_size_t)our_pseudo_label); - token_location_override(current_location_minus_one()); - gg_insert_into_assembler( ach ); } static void @@ -8547,12 +8561,7 @@ perform_outofline_testafter_varying(struct cbl_perform_tgt_t *tgt, // only need N-1; we don't use the zeroth pair. But the code // is cleaner if we just build all N of them. - char ach[256]; - size_t our_pseudo_label = pseudo_label++; - sprintf(ach, - "_proccallb." HOST_SIZE_T_PRINT_DEC ":", - (fmt_size_t)our_pseudo_label); - gg_insert_into_assembler( ach ); + perform_is_armed = CURRENT_LINE_NUMBER ; create_iline_address_pairs(tgt); @@ -8604,11 +8613,6 @@ 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." HOST_SIZE_T_PRINT_DEC ":", - (fmt_size_t)our_pseudo_label); - token_location_override(current_location_minus_one()); - gg_insert_into_assembler( ach ); } static void @@ -8665,12 +8669,7 @@ perform_outofline_before_varying( struct cbl_perform_tgt_t *tgt, tree label[MAX_AFTERS]; build_N_pairs(go_to, label, N); - char ach[256]; - size_t our_pseudo_label = pseudo_label++; - sprintf(ach, - "_proccallb." HOST_SIZE_T_PRINT_DEC ":", - (fmt_size_t)our_pseudo_label); - gg_insert_into_assembler( ach ); + perform_is_armed = CURRENT_LINE_NUMBER ; // Initialize all varying: @@ -8748,11 +8747,6 @@ perform_outofline_before_varying( struct cbl_perform_tgt_t *tgt, // the EXIT: label. // We have, you see, reached the egress: gg_append_statement( tgt->addresses.exit.label ); - sprintf(ach, - "_procretb." HOST_SIZE_T_PRINT_DEC ":", - (fmt_size_t)our_pseudo_label); - token_location_override(current_location_minus_one()); - gg_insert_into_assembler( ach ); } static void @@ -8983,6 +8977,9 @@ perform_inline_testbefore_varying( struct cbl_perform_tgt_t *tgt, SHOW_PARSE_END } gg_append_statement(tgt->addresses.condback[i].label); + // Needed to make GDB NEXT over PERFORM in-line VARYING UNTIL work + // predictably. + insert_nop(107); // Test that conditional parser_if(varys[i].until); @@ -13407,10 +13404,6 @@ create_and_call(size_t narg, if( returned.field ) { - // 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. diff --git a/gcc/cobol/gengen.cc b/gcc/cobol/gengen.cc index fa792d618bb..208d4910527 100644 --- a/gcc/cobol/gengen.cc +++ b/gcc/cobol/gengen.cc @@ -1843,6 +1843,10 @@ gg_create_goto_pair(tree *goto_expr, void_type_node); DECL_CONTEXT(label_decl) = current_function->function_decl; TREE_USED(label_decl) = 1; + DECL_EXTERNAL(label_decl) = 1; + TREE_PUBLIC(label_decl) = 1; + TREE_ADDRESSABLE(label_decl) = 1; + TREE_STATIC(label_decl) = 1; *goto_expr = build1(GOTO_EXPR, void_type_node, label_decl); *label_expr = build1(LABEL_EXPR, void_type_node, label_decl); diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index bcd8d6f3105..1311797f03d 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -1894,10 +1894,17 @@ comminit: COMMON { ; -env_div: %empty { current_division = environment_div_e; } - | ENVIRONMENT_DIV '.' { current_division = environment_div_e; } +env_div: %empty { + current_division = environment_div_e; + parser_division( environment_div_e, NULL, 0, NULL ); + } + | ENVIRONMENT_DIV '.' { + current_division = environment_div_e; + parser_division( environment_div_e, NULL, 0, NULL ); + } | ENVIRONMENT_DIV '.' { current_division = environment_div_e; + parser_division( environment_div_e, NULL, 0, NULL ); } env_sections ; @@ -3159,12 +3166,14 @@ when_set_to: %empty | WHEN SET TO ; -data_div: %empty - | DATA_DIV - | DATA_DIV { current_division = data_div_e; } data_sections - { +data_div: %empty { parser_division( data_div_e, NULL, 0, NULL ); } + | DATA_DIV { parser_division( data_div_e, NULL, 0, NULL ); } + | DATA_DIV { + current_division = data_div_e; + parser_division( data_div_e, NULL, 0, NULL ); + } + data_sections { current_data_section = not_data_datasect_e; - parser_division( data_div_e, NULL, 0, NULL ); } ; @@ -4091,8 +4100,9 @@ data_descr1: level_name if( $field->has_attr(blank_zero_e) ) { switch($field->type) { case FldNumericEdited: - if( $field->has_attr(signable_e) ) { - error_msg(@2, "%s has 'S' in PICTURE, cannot be BLANK WHEN ZERO", + // Test appears to be invalid. + if( false && $field->has_attr(signable_e) ) { + error_msg(@2, "%s has signed PICTURE, cannot be BLANK WHEN ZERO", $field->name ); } break; @@ -4446,6 +4456,10 @@ picture_clause: PIC signed nps[fore] nines nps[aft] if( field->has_attr(signable_e) && ! $signed ) { dbgmsg("%s PICTURE must be signed for SIGN IS", field->name); } + if( field->type == FldNumericEdited && $signed ) { + gcc_assert(field->has_attr(blank_zero_e)); + error_msg(@signed, "% in PICTURE invalid with BLANK WHEN ZERO"); + } field->attr |= $signed; field->data.digits = $nines; auto nchar = type_capacity(field->type, $nines); @@ -4474,6 +4488,10 @@ picture_clause: PIC signed nps[fore] nines nps[aft] } field->data.digits = $left + $rdigits; field->attr |= $signed; + if( field->type == FldNumericEdited && $signed ) { + gcc_assert(field->has_attr(blank_zero_e)); + error_msg(@signed, "% in PICTURE invalid with BLANK WHEN ZERO"); + } if( field->is_binary_integer() ) { field->set_capacity(type_capacity(field->type, @@ -4511,6 +4529,10 @@ picture_clause: PIC signed nps[fore] nines nps[aft] } ERROR_IF_CAPACITY(@PIC, field); field->attr |= $signed; + if( $signed ) { + gcc_assert(field->has_attr(blank_zero_e)); + error_msg(@signed, "% in PICTURE invalid with BLANK WHEN ZERO"); + } field->data.digits = size; field->set_capacity(++size); field->data.rdigits = $rdigits; @@ -4573,6 +4595,7 @@ picture_clause: PIC signed nps[fore] nines nps[aft] field->data.digits = digits_of_picture($picture, false); field->data.rdigits = rdigits_of_picture($picture); if( is_picture_scaled($picture) ) field->attr |= scaled_e; + field->set_signable(); auto nchar = length_of_picture($picture); field->set_capacity(nchar); field->blank_initial(nchar); @@ -5038,19 +5061,24 @@ based_clause: BASED } ; -blank_zero_clause: blank_when_zero - { cbl_field_t *field = current_field(); - // the BLANK WHEN ZERO clause defines the item as numeric-edited. +blank_zero_clause: BLANK when ZERO + { // BLANK WHEN ZERO defines the item as numeric-edited. + cbl_field_t *field = current_field(); + auto attr = blank_zero_e; if( !field_type_update(field, FldNumericEdited, @1) ) { - YYERROR; + attr = none_e; + if( field->type == FldNumericDisplay ) { + assert(field->has_attr(signable_e)); + error_msg(@$, "signed NUMERIC DISPLAY type " + "cannot have BLANK WHEN ZERO"); + } else { + assert(is_numeric(field)); + error_msg(@$, "NUMERIC type cannot have BLANK WHEN ZERO"); + } } - field->attr |= blank_zero_e; + field->set_attr(attr); } ; -blank_when_zero: - BLANK WHEN ZERO - | BLANK ZERO - ; synched_clause: SYNCHRONIZED | SYNCHRONIZED LEFT @@ -5197,14 +5225,14 @@ volatile_clause: procedure_div: %empty { if( !procedure_division_ready(@$, NULL, NULL) ) YYABORT; } - | PROCEDURE_DIV '.' { - if( !procedure_division_ready(@$, NULL, NULL) ) YYABORT; - } declaratives sentences - | PROCEDURE_DIV procedure_args '.' declaratives sentences | PROCEDURE_DIV procedure_args '.' + | PROCEDURE_DIV procedure_args '.' declaratives sentences ; -procedure_args: USING procedure_uses[args] +procedure_args: %empty { + if( !procedure_division_ready(@$, NULL, NULL) ) YYABORT; + } + | USING procedure_uses[args] { if( !procedure_division_ready(@args, NULL, $args) ) YYABORT; } @@ -11824,6 +11852,10 @@ user_default: DEFAULT } ; +when: %empty + | WHEN + ; + with: %empty | WITH ; diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h index 12d944f3ab7..88950a95995 100644 --- a/gcc/cobol/parse_ante.h +++ b/gcc/cobol/parse_ante.h @@ -2949,8 +2949,9 @@ field_type_update( cbl_field_t *field, cbl_field_type_t type, bool is_usage = false) { // preserve NumericEdited if already established - if( !is_usage && field->has_attr(blank_zero_e) ) { - if( type == FldNumericDisplay && field->type == FldNumericEdited ) { + if( !is_usage ) { + if( field->type == FldNumericEdited && type == FldNumericDisplay ) { + assert(field->has_attr(blank_zero_e)); return true; } } @@ -2971,8 +2972,10 @@ field_type_update( cbl_field_t *field, cbl_field_type_t type, } if( ! symbol_field_type_update(field, type, is_usage) ) { - error_msg(loc, "cannot set USAGE of %s to %s (from %s)", field->name, - cbl_field_type_str(type) + 3, cbl_field_type_str(field->type) + 3); + if( type != FldNumericEdited ) { // caller prints message + error_msg(loc, "cannot set USAGE of %s to %s (from %s)", field->name, + cbl_field_type_str(type) + 3, cbl_field_type_str(field->type) + 3); + } return false; } diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index a94ef8bddfa..731f51afbdb 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -816,6 +816,40 @@ cbl_field_t::clear_attr( cbl_field_attr_t attr ) { return this->attr &= ~uint64_t(attr); } +// Test various ways a Numeric Edited picture can describe a signed value. +uint64_t +cbl_field_t::set_signable() { + gcc_assert(type == FldNumericEdited); + gcc_assert(data.picture); + char *p = xstrdup(data.picture); + char *pend; + // Look to see if this is a floating-point numeric-edited: + pend = strchr(p, ascii_e); + if( !pend ) { + pend = strchr(p, ascii_E); + } + if( pend ) { + // We end our inspection at the 'E' + *pend = '\0'; + } + size_t len = strlen(p); + if( p[0] == ascii_plus || p[0] == ascii_minus ) { + // The very first character is plus or minus + set_attr(signable_e); + } else if( len >= 1 && (p[len-1] == ascii_plus || p[len-1] == ascii_minus)) { + // The very last character is plus or minus + set_attr(signable_e); + } + else if( len >= 2 && + ( (TOUPPER(p[len-2]) == ascii_D && TOUPPER(p[len-1]) == ascii_B) + || (TOUPPER(p[len-2]) == ascii_C && TOUPPER(p[len-1]) == ascii_R) ) ) { + // The last two characters are DB or CR + set_attr(signable_e); + } + free(p); + return attr; +} + static uint32_t field_memsize( const struct cbl_field_t *field ) { uint32_t n = field->occurs.ntimes(); @@ -4094,10 +4128,15 @@ cbl_field_t::encode( size_t srclen, cbl_loc_t loc ) { if( inbytesleft == 0 ) { if( data.all() ) { - for( size_t len = outbuf - data.initial; - outbuf + len <= data.initial + data.capacity(); - outbuf += len ) { - std::copy( data.initial, data.initial + len, outbuf ); + size_t len = outbuf - data.initial; + // We need to repeatedly append the first len bytes of data.initial to + // data.initial until it is full. Thus ALL "ABC" becomes "ABCABC..." + char *d = const_cast(data.initial); + size_t source_i = 0; + size_t dest_i = len; + while( dest_i < static_cast(data.capacity()) ) { + d[dest_i++] = d[source_i++]; + source_i %= len; } } if( is_literal(this) ) { diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h index 7a362564efe..511198a870e 100644 --- a/gcc/cobol/symbols.h +++ b/gcc/cobol/symbols.h @@ -889,6 +889,7 @@ struct cbl_field_t { 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& attrs ) const; + uint64_t set_signable(); bool is_justifiable() const { if( type == FldAlphanumeric ) return true; diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc index f27db2ad6e2..42c67cafca8 100644 --- a/gcc/cobol/util.cc +++ b/gcc/cobol/util.cc @@ -970,25 +970,38 @@ symbol_field_type_update( cbl_field_t *field, * Concrete type candidate */ switch(field->usage) { - case FldInvalid: - field->type = candidate; - field->attr |= numeric_group_attrs(field); - // update encoding + case FldInvalid: // no USAGE clause yet, and not now either + // maybe update encoding switch( field->type ) { - case FldNumericDisplay: case FldAlphaEdited: case FldNumericEdited: + field->type = candidate; + field->attr |= numeric_group_attrs(field); return field->codeset.set(); + case FldNumericDisplay: + // If the field is already defined as Numeric Display, it cannot be + // converted to Numeric Edited if it is signed. + if( candidate == FldNumericEdited) { + if( field->has_attr(signable_e) ) return false; + } + break; default: + // If the field is already defined as a binary numeric type (not + // Display), it cannot be converted to NumericEdited. + if( candidate == FldNumericEdited) { + if( is_numeric(field->type) ) return false; + } break; } + field->type = candidate; + field->attr |= numeric_group_attrs(field); 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; + if( field->codeset.valid() ) return true; + return field->codeset.set(); } break; case FldAlphaEdited: @@ -1586,7 +1599,11 @@ cbl_field_t::encode_numeric( const char input[], cbl_loc_t loc, } if( l_digits - l_rdigits > data.digits - data.rdigits ) { - error_msg(loc, "VALUE has too many integer digits"); + // This error is caught earlier by validate_numeric_edited + if( type != FldNumericEdited ) + { + error_msg(loc, "VALUE has too many integer digits"); + } } } } @@ -1606,6 +1623,7 @@ cbl_field_t::encode_numeric( const char input[], cbl_loc_t loc, switch(type) { case FldNumericBin5: + case FldIndex: case FldLiteralN: { binary_initial(retval, this, value, l_rdigits); diff --git a/libgcobol/valconv.cc b/libgcobol/valconv.cc index 012f881d4cd..ef5faae576c 100644 --- a/libgcobol/valconv.cc +++ b/libgcobol/valconv.cc @@ -231,10 +231,10 @@ __gg__string_to_numeric_edited( char * const dest, int dlength = expand_picture(dest, picture); - // At the present time, I am taking a liberty. In principle, a 'V' - // character is supposed to be logical decimal place rather than a physical - // one. In practice, I am not sure what that would mean in a numeric edited - // value. So, I am treating V as a decimal point. + // We need to treat 'V' as a decimal point in order to handle + // 01 foo pic 999v999 BLANK WHEN ZERO. + // The "BLANK WHEN ZERO" turns the field into a numeric-edited type, but the + // 'V' is still in the picture string. for(int i=0; i