>From 203cbbc22fd8c8ffbc29eb846d8901e4346e95f8 Mon Sep 17 00:00:00 2001
From: Robert Dubner mailto:[email protected]
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<int, int> 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 <inline> 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:
+ <conditional calculation>
+ 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:
+ <conditional calculation>
+ 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, "%<S%> 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, "%<S%> 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, "%<S%> 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<char*>(data.initial);
+ size_t source_i = 0;
+ size_t dest_i = len;
+ while( dest_i < static_cast<size_t>(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<cbl_field_attr_t>& 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<dlength; i++)
{
--
2.34.1
