From: Robert Dubner <[email protected]>
Date: Wed, 18 Feb 2026 23:01:38 -0500
Subject: [PATCH] cobol: Improve generated code for fast_add and
fast_subtract.
These changes improve the efficiency of generated code by recognizing
more instances where operations are on little-endian binary COBOL
variables and then avoiding calls to libgcobol. The generated code
also reduces the number of intermediate variables created for that
little-endian arithmetic.
gcc/cobol/ChangeLog:
* genapi.cc (tree_type_from_field_type): Move static code.
(compare_binary_binary): Identify little-endian compares.
(psa_FldLiteralN): Eliminate obsolete development code; make the
initialized variables TREE_CONSTANT.
(parser_symbol_add): Adjust for modified FldLiteralN.
* genmath.cc (all_results_binary): Renamed. Modified for fastness.
(all_results_integer): Likewise.
(all_refers_integer): Likewise.
(largest_binary_term): Likewise.
(fast_add): Expand conditions. Use get_binary_value_tree.
(fast_subtract): Likewise.
(fast_multiply): Expand conditions.
(fast_divide): Expand conditions.
(parser_add): Avoid fast_add when error or not-error are
specified.
(parser_multiply): Likewise.
(parser_divide): Likewise.
(parser_subtract): Likewise.
* genutil.cc (tree_type_from_field): Disable; flagged for removal.
(get_binary_value): Use get_binary_value_tree.
(get_binary_value_tree): Avoid intermediate variables when
possible.
(refer_is_clean): Formatting.
(is_pure_integer): Refine test for little-endian binary.
* genutil.h (get_binary_value_tree): New declaration.
(is_pure_integer): New declaration.
* symbols.cc (symbol_table_init): Explanatory ZEROS comment.
libgcobol/ChangeLog:
* gfileio.cc (__gg__file_reopen): Raise exception on failed OPEN
* gmath.cc (__gg__fixed_phase2_assign_to_c): Let pointer
arithmetic
go negative.
(__gg__subtractf2_fixed_phase1): Edit a comment.
---
gcc/cobol/genapi.cc | 253 ++++++++++++++++-----------
gcc/cobol/genmath.cc | 408 +++++++++++++++++++++++++++++++++----------
gcc/cobol/genutil.cc | 197 ++++++++++++++++-----
gcc/cobol/genutil.h | 10 ++
gcc/cobol/symbols.cc | 3 +-
libgcobol/gfileio.cc | 4 +
libgcobol/gmath.cc | 17 +-
7 files changed, 648 insertions(+), 244 deletions(-)
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index 78122c12b16..dcf49c7a90e 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -2028,6 +2028,102 @@ normal_normal_compare(bool debugging,
}
}
+static
+tree
+tree_type_from_field_type(cbl_field_t *field, size_t &nbytes)
+ {
+ /* This routine is used to determine what action is taken with type of
a
+ CALL ... USING <var> and the matching PROCEDURE DIVISION USING
<var> of
+ a PROGRAM-ID or FUNCTION-ID
+ */
+ tree retval = COBOL_FUNCTION_RETURN_TYPE;
+ nbytes = 8;
+ if( field )
+ {
+ // This maps a Fldxxx to a C-style variable type:
+ switch(field->type)
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ case FldAlphaEdited:
+ case FldNumericEdited:
+ retval = CHAR_P;
+ nbytes = field->data.capacity();
+ break;
+
+ case FldNumericDisplay:
+ case FldNumericBinary:
+ case FldPacked:
+ if( field->data.digits > 18 )
+ {
+ retval = UINT128;
+ nbytes = 16;
+ }
+ else
+ {
+ retval = SIZE_T;
+ nbytes = 8;
+ }
+ break;
+
+ case FldNumericBin5:
+ case FldIndex:
+ case FldPointer:
+ if( field->data.capacity() > 8 )
+ {
+ retval = UINT128;
+ nbytes = 16;
+ }
+ else
+ {
+ retval = SIZE_T;
+ nbytes = 8;
+ }
+ break;
+
+ case FldFloat:
+ if( field->data.capacity() == 8 )
+ {
+ retval = DOUBLE;
+ nbytes = 8;
+ }
+ else if( field->data.capacity() == 4 )
+ {
+ retval = FLOAT;
+ nbytes = 4;
+ }
+ else
+ {
+ retval = FLOAT128;
+ nbytes = 16;
+ }
+ break;
+
+ case FldLiteralN:
+ // Assume a 64-bit signed integer. This happens for GOBACK
STATUS 101,
+ // the like
+ retval = LONG;
+ nbytes = 8;
+ break;
+
+ default:
+ cbl_internal_error( "%s: Invalid field type %s:",
+ __func__,
+ cbl_field_type_str(field->type));
+ break;
+ }
+ if( retval == SIZE_T && field->attr & signable_e )
+ {
+ retval = SSIZE_T;
+ }
+ if( retval == UINT128 && field->attr & signable_e )
+ {
+ retval = INT128;
+ }
+ }
+ return retval;
+ }
+
static void
compare_binary_binary(tree return_int,
cbl_refer_t *left_side_ref,
@@ -2040,6 +2136,54 @@ compare_binary_binary(tree return_int,
tree left_side;
tree right_side;
+ // Let's check for the simplified case where both left and right sides
are
+ // little-endian binary values:
+
+ if( is_pure_integer(left_side_ref->field)
+ && is_pure_integer(right_side_ref->field) )
+ {
+ size_t left_bytes;
+ tree left_type = tree_type_from_field_type(left_side_ref->field,
+ left_bytes);
+ size_t right_bytes;
+ tree right_type = tree_type_from_field_type(right_side_ref->field,
+ right_bytes);
+ tree larger;
+ if( TREE_INT_CST_LOW(TYPE_SIZE(left_type))
+ > TREE_INT_CST_LOW(TYPE_SIZE(right_type)) )
+ {
+ larger = left_type;
+ }
+ else
+ {
+ larger = right_type;
+ }
+ left_side = get_binary_value_tree(larger,
+ NULL,
+ *left_side_ref);
+ right_side = get_binary_value_tree(larger,
+ NULL,
+ *right_side_ref);
+ IF( left_side, eq_op, right_side )
+ {
+ gg_assign(return_int, integer_zero_node);
+ }
+ ELSE
+ {
+ IF( left_side, lt_op, right_side )
+ {
+ gg_assign(return_int, integer_minusone_node);
+ }
+ ELSE
+ {
+ gg_assign(return_int, integer_one_node);
+ }
+ ENDIF
+ }
+ ENDIF
+ return;
+ }
+
// Use SIZE128 when we need two 64-bit registers to hold the value.
All
// others fit into 64-bit LONG with pretty much the same efficiency.
@@ -4133,11 +4277,7 @@ psa_FldLiteralN(struct cbl_field_t *field )
uint32_t digits;
int32_t rdigits;
uint64_t attr;
- //// DUBNERHACK. Necessary to prevent UAT lockup:
- const char *source_text = field->data.original()
- ? field->data.original()
- : field->data.initial;
- FIXED_WIDE_INT(128) value = dirty_to_binary(source_text,
+ FIXED_WIDE_INT(128) value = dirty_to_binary(field->data.original(),
capacity,
digits,
rdigits,
@@ -4167,7 +4307,9 @@ psa_FldLiteralN(struct cbl_field_t *field )
tree new_var_decl = gg_define_variable( var_type,
base_name,
vs_static);
- DECL_INITIAL(new_var_decl) = wide_int_to_tree(var_type, value);
+ DECL_INITIAL(new_var_decl) = wide_int_to_tree(var_type, value);
+ TREE_CONSTANT(new_var_decl) = 1;
+
field->data_decl_node = new_var_decl;
// Note that during compilation, the integer value, assuming it can be
@@ -6148,102 +6290,6 @@ vs_file_static);
gg_free(ttbls);
}
-static
-tree
-tree_type_from_field_type(cbl_field_t *field, size_t &nbytes)
- {
- /* This routine is used to determine what action is taken with type of
a
- CALL ... USING <var> and the matching PROCEDURE DIVISION USING
<var> of
- a PROGRAM-ID or FUNCTION-ID
- */
- tree retval = COBOL_FUNCTION_RETURN_TYPE;
- nbytes = 8;
- if( field )
- {
- // This maps a Fldxxx to a C-style variable type:
- switch(field->type)
- {
- case FldGroup:
- case FldAlphanumeric:
- case FldAlphaEdited:
- case FldNumericEdited:
- retval = CHAR_P;
- nbytes = field->data.capacity();
- break;
-
- case FldNumericDisplay:
- case FldNumericBinary:
- case FldPacked:
- if( field->data.digits > 18 )
- {
- retval = UINT128;
- nbytes = 16;
- }
- else
- {
- retval = SIZE_T;
- nbytes = 8;
- }
- break;
-
- case FldNumericBin5:
- case FldIndex:
- case FldPointer:
- if( field->data.capacity() > 8 )
- {
- retval = UINT128;
- nbytes = 16;
- }
- else
- {
- retval = SIZE_T;
- nbytes = 8;
- }
- break;
-
- case FldFloat:
- if( field->data.capacity() == 8 )
- {
- retval = DOUBLE;
- nbytes = 8;
- }
- else if( field->data.capacity() == 4 )
- {
- retval = FLOAT;
- nbytes = 4;
- }
- else
- {
- retval = FLOAT128;
- nbytes = 16;
- }
- break;
-
- case FldLiteralN:
- // Assume a 64-bit signed integer. This happens for GOBACK
STATUS 101,
- // the like
- retval = LONG;
- nbytes = 8;
- break;
-
- default:
- cbl_internal_error( "%s: Invalid field type %s:",
- __func__,
- cbl_field_type_str(field->type));
- break;
- }
- if( retval == SIZE_T && field->attr & signable_e )
- {
- retval = SSIZE_T;
- }
- if( retval == UINT128 && field->attr & signable_e )
- {
- retval = INT128;
- }
- }
- return retval;
- }
-
static void
restore_local_variables()
{
@@ -17428,7 +17474,8 @@ parser_symbol_add(struct cbl_field_t *new_var )
free(level_88_string);
free(class_string);
- if( !(new_var->attr & ( linkage_e | based_e)) )
+ if( !(new_var->attr & ( linkage_e | based_e))
+ && !(new_var->type == FldLiteralN) )
{
static const bool explicitly = false;
static const bool just_once = true;
diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc
index 18ba682f30b..6eb87544ac0 100644
--- a/gcc/cobol/genmath.cc
+++ b/gcc/cobol/genmath.cc
@@ -329,13 +329,29 @@ is_somebody_float(size_t nC, const cbl_num_result_t
*C)
}
static bool
-all_results_binary(size_t nC, const cbl_num_result_t *C)
+all_results_integer(size_t nC, const cbl_num_result_t *C)
{
bool retval = true;
for(size_t i=0; i<nC; i++)
{
- if(C[i].refer.field->data.digits != 0 || C[i].refer.field->type ==
FldFloat )
+ if( !is_pure_integer(C[i].refer.field) )
+ {
+ retval = false;
+ break;
+ }
+ }
+ return retval;
+ }
+
+static bool
+all_refers_integer(size_t nC, const cbl_refer_t *C)
+ {
+ bool retval = true;
+
+ for(size_t i=0; i<nC; i++)
+ {
+ if( !is_pure_integer(C[i].field) )
{
retval = false;
break;
@@ -353,18 +369,20 @@ largest_binary_term(size_t nA, cbl_refer_t *A)
for(size_t i=0; i<nA; i++)
{
- if( A[i].field->data.rdigits || A[i].field->type == FldFloat )
+ if( !is_pure_integer(A[i].field) || A[i].field->type == FldFloat )
{
- // We are prepared to work only with integers
+ // We are prepared to work only with binary integers
retval = NULL_TREE;
break;
}
if( A[i].field->type == FldLiteralN
-// || A[i].field->type == FldNumericDisplay
|| A[i].field->type == FldNumericBinary
|| A[i].field->type == FldNumericBin5
|| A[i].field->type == FldIndex
- || A[i].field->type == FldPointer )
+ || A[i].field->type == FldPointer
+ || ( A[i].field->type == FldAlphanumeric
+ && strcmp(A[i].field->name, "ZEROS") == 0 )
+ )
{
// This is an integer type that can be worked with quickly
is_negative |= ( A[i].field->attr & signable_e );
@@ -386,62 +404,173 @@ fast_add( size_t nC, cbl_num_result_t *C,
size_t nA, cbl_refer_t *A,
cbl_arith_format_t format )
{
+ /* ADD A TO D: nC==1, nA==1, D += A.
+ ADD A B C TO D: nC==1, nA==3, D = (A + B + C)
+ ADD A B C TO D E nC==2, nA==3
+ ADD A TO B GIVING D nC==1, nA==2, format==giving_e
+ ADD A B C TO D GIVING X Y nC==2, nA==3, format==giving_e */
bool retval = false;
- if( all_results_binary(nC, C) )
+ if( all_results_integer(nC, C)
+ && all_refers_integer(nA, A) )
{
Analyze();
// All targets are non-PICTURE binaries:
tree term_type = largest_binary_term(nA, A);
if( term_type )
{
- // All the terms are things we can work with.
-
- // We need to calculate the sum of all the A[] terms using
term_type as
- // the intermediate type:
-
- tree sum = gg_define_variable(term_type);
- tree addend = gg_define_variable(term_type);
- get_binary_value( sum,
- NULL,
- A[0].field,
- refer_offset(A[0]));
-
- // Add in the rest of them:
- for(size_t i=1; i<nA; i++)
+ tree dest_type = tree_type_from_size(
+
C[0].refer.field->data.capacity(),
+ 0);
+ // All the numbers are integers without rdigits
+ if( nC == 1
+ && nA == 1
+ && format != giving_e
+ )
{
- get_binary_value( addend,
- NULL,
- A[i].field,
- refer_offset(A[i]));
- gg_assign(sum, gg_add(sum, addend));
- }
- //gg_printf("The intermediate sum is %ld\n", gg_cast(LONG, sum),
NULL_TREE);
+ // This is the simplest case of all. Just add A to C. We can't
+ // naively add A to multiple C, because of the possibility of
+ // ADD A TO A B C. That would change A before A gets added to B
and
+ // C, which is not how COBOL works.
- // We now either accumulate into C[n] or assign to C[n]:
- for(size_t i=0; i<nC; i++ )
- {
- tree dest_type =
tree_type_from_size(C[i].refer.field->data.capacity(), 0);
- tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node,
"data"),
- refer_offset(C[i].refer));
- tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
- if( format == giving_e )
+ tree A_value;
+ if( refer_is_clean(A[0]) )
+ {
+ A_value = get_binary_value_tree(dest_type,
+ NULL, // No rdigits
+ A[0].field,
+ integer_zero_node);
+ }
+ else
{
- // We are assigning
+ A_value = get_binary_value_tree(dest_type,
+ NULL, // No rdigits
+ A[0].field,
+ refer_offset(A[0]));
+ }
+ if( refer_is_clean(C[0].refer) )
+ {
+ tree dest_addr = member(C[0].refer.field->var_decl_node,
+ "data");
+ tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
+ // We are accumulating into memory
gg_assign( gg_indirect(ptr),
- gg_cast(dest_type, sum));
+ gg_add( gg_indirect(ptr),
+ A_value));
}
else
{
- // We are accumulating
+ tree dest_addr = gg_add(member(C[0].refer.field->var_decl_node,
+ "data"),
+ refer_offset(C[0].refer));
+ tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
+ // We are accumulating into memory
gg_assign( gg_indirect(ptr),
gg_add( gg_indirect(ptr),
- gg_cast(dest_type, sum)));
+ A_value));
+ }
+ }
+ else if( nC == 1
+ && nA == 2
+ && format == giving_e )
+ {
+ // This is the very common ADD A TO B GIVING C
+ {
+ // Make C = A[0] + A[1]
+ tree dest_addr;
+ if( refer_is_clean(C[0].refer) )
+ {
+ dest_addr = member(C[0].refer.field->var_decl_node, "data");
+ }
+ else
+ {
+ dest_addr = gg_add(member(C[0].refer.field->var_decl_node,
"data"),
+ refer_offset(C[0].refer));
+ }
+ dest_addr = gg_cast(build_pointer_type(dest_type), dest_addr);
+
+ tree A_value;
+ if( refer_is_clean(A[0]) )
+ {
+ A_value = get_binary_value_tree(dest_type,
+ NULL, // No rdigits
+ A[0].field,
+ integer_zero_node);
+ }
+ else
+ {
+ A_value = get_binary_value_tree(dest_type,
+ NULL, // No rdigits
+ A[0].field,
+ refer_offset(A[0]));
+ }
+
+ tree B_value;
+ if( refer_is_clean(A[1]) )
+ {
+ B_value = get_binary_value_tree(dest_type,
+ NULL, // No rdigits
+ A[1].field,
+ integer_zero_node);
+ }
+ else
+ {
+ B_value = get_binary_value_tree(dest_type,
+ NULL, // No rdigits
+ A[1].field,
+ refer_offset(A[1]));
+ }
+
+ gg_assign( gg_indirect(dest_addr),
+ gg_add( A_value,
+ B_value));
+ }
+ }
+ else
+ {
+ // We need to calculate the sum of all the A[] terms using
term_type as
+ // the intermediate type:
+
+ tree sum = gg_define_variable(term_type);
+ tree addend = gg_define_variable(term_type);
+ get_binary_value( sum,
+ NULL,
+ A[0].field,
+ refer_offset(A[0]));
+
+ // Add in the rest of them:
+ for(size_t i=1; i<nA; i++)
+ {
+ get_binary_value( addend,
+ NULL,
+ A[i].field,
+ refer_offset(A[i]));
+ gg_assign(sum, gg_add(sum, addend));
+ }
+
+ // We now either accumulate into C[n] or assign to C[n]:
+ for(size_t i=0; i<nC; i++ )
+ {
+ tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node,
+ "data"),
+ refer_offset(C[i].refer));
+ tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
+ if( format == giving_e )
+ {
+ // We are assigning
+ gg_assign( gg_indirect(ptr),
+ gg_cast(dest_type, sum));
+ }
+ else
+ {
+ // We are accumulating
+ gg_assign( gg_indirect(ptr),
+ gg_add( gg_indirect(ptr),
+ gg_cast(dest_type, sum)));
+ }
}
}
retval = true;
}
-
- //gg_insert_into_assembler("# DUBNER addition END ");
}
return retval;
}
@@ -452,8 +581,15 @@ fast_subtract(size_t nC, cbl_num_result_t *C,
size_t nB, cbl_refer_t *B,
cbl_arith_format_t format)
{
+ /* SUBTRACT A FROM D: nC==1, nA==1, nB==0: D -= A.
+ SUBTRACT A B C FROM D: nC==1, nA==3, nB==0: D -= (A + B + C)
+ SUBTRACT A B C FROM D E nC==2, nA==3
+ SUBTRACT A B C FROM D GIVING X Y
+ nC==2, nA==3, nB==1 */
bool retval = false;
- if( all_results_binary(nC, C) )
+ if( all_refers_integer(nA, A)
+ && all_refers_integer(nB, B)
+ && all_results_integer(nC, C) )
{
Analyze();
// All targets are non-PICTURE binaries:
@@ -480,48 +616,136 @@ fast_subtract(size_t nC, cbl_num_result_t *C,
if( term_type )
{
// All the terms are things we can work with.
+ // All the numbers are integers without rdigits
+ if( nC == 1
+ && nA == 1
+ && nB <= 1
+ )
+ {
+ // This is the simplest case of all. Just subtract A from C.
+ tree dest_type = tree_type_from_size(
+
C[0].refer.field->data.capacity(),
+ 0);
+ tree A_value;
+ if( refer_is_clean(A[0]) )
+ {
+ A_value = get_binary_value_tree(dest_type,
+ NULL, // No rdigits
+ A[0].field,
+ integer_zero_node);
+ }
+ else
+ {
+ A_value = get_binary_value_tree(dest_type,
+ NULL, // No rdigits
+ A[0].field,
+ refer_offset(A[0]));
+ }
+ if( format == giving_e )
+ {
+ // Make C = B - A
+ tree dest_addr;
+ if( refer_is_clean(C[0].refer) )
+ {
+ dest_addr = member(C[0].refer.field->var_decl_node, "data");
+ }
+ else
+ {
+ dest_addr = gg_add(member(C[0].refer.field->var_decl_node,
"data"),
+ refer_offset(C[0].refer));
+ }
+ dest_addr = gg_cast(build_pointer_type(dest_type), dest_addr);
- // We need to calculate the sum of all the A[] terms using
term_type as
- // the intermediate type:
-
- tree sum = gg_define_variable(term_type);
- tree addend = gg_define_variable(term_type);
- get_binary_value(sum, NULL, A[0].field, refer_offset(A[0]));
+ tree B_value;
+ if( refer_is_clean(B[0]) )
+ {
+ B_value = get_binary_value_tree(dest_type,
+ NULL, // No rdigits
+ B[0].field,
+ integer_zero_node);
+ }
+ else
+ {
+ B_value = get_binary_value_tree(dest_type,
+ NULL, // No rdigits
+ B[0].field,
+ refer_offset(B[0]));
+ }
- // Add in the rest of them:
- for(size_t i=1; i<nA; i++)
- {
- get_binary_value(sum, NULL, A[i].field, refer_offset(A[i]));
- gg_assign(sum, gg_add(sum, addend));
+ gg_assign( gg_indirect(dest_addr),
+ gg_cast(dest_type, gg_subtract( B_value,
+ A_value)));
+ }
+ else
+ {
+ // Make C = C - A
+ if( refer_is_clean(C[0].refer) )
+ {
+ tree dest_addr = member(C[0].refer.field->var_decl_node,
+ "data");
+ tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
+ // We are subtracting from memory
+ gg_assign( gg_indirect(ptr),
+ gg_subtract( gg_indirect(ptr),
+ A_value));
+ }
+ else
+ {
+ tree dest_addr =
gg_add(member(C[0].refer.field->var_decl_node,
+ "data"),
+ refer_offset(C[0].refer));
+ tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
+ // We are subtracting from memory
+ gg_assign( gg_indirect(ptr),
+ gg_subtract( gg_indirect(ptr),
+ A_value));
+ }
+ }
}
- //gg_printf("The intermediate sum is %ld\n", gg_cast(LONG, sum),
NULL_TREE);
-
- if( format == giving_e )
+ else
{
- // We now subtract the sum from B[0]
- get_binary_value(addend, NULL, B[0].field, refer_offset(B[0]));
- gg_assign(sum, gg_subtract(addend, sum));
- }
+ // We need to calculate the sum of all the A[] terms using
term_type as
+ // the intermediate type:
+
+ tree sum = gg_define_variable(term_type);
+ tree addend = gg_define_variable(term_type);
+ get_binary_value(sum, NULL, A[0].field, refer_offset(A[0]));
+
+ // Add in the rest of them:
+ for(size_t i=1; i<nA; i++)
+ {
+ get_binary_value(addend, NULL, A[i].field, refer_offset(A[i]));
+ gg_assign(sum, gg_add(sum, addend));
+ }
+ //gg_printf("The intermediate sum is %ld\n", gg_cast(LONG, sum),
NULL_TREE);
- // We now either accumulate into C[n] or assign to C[n]:
- for(size_t i=0; i<nC; i++ )
- {
- tree dest_type =
tree_type_from_size(C[i].refer.field->data.capacity(), 0);
- tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node,
"data"),
- refer_offset(C[i].refer));
- tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
if( format == giving_e )
{
- // We are assigning
- gg_assign( gg_indirect(ptr),
- gg_cast(dest_type, sum));
+ // We now subtract the sum from B[0]
+ get_binary_value(addend, NULL, B[0].field, refer_offset(B[0]));
+ gg_assign(sum, gg_subtract(addend, sum));
}
- else
+
+ // We now either accumulate into C[n] or assign to C[n]:
+ for(size_t i=0; i<nC; i++ )
{
- // We are subtracting the sum from C[i]
- gg_assign( gg_indirect(ptr),
- gg_subtract(gg_indirect(ptr),
- gg_cast(dest_type, sum)));
+ tree dest_type =
tree_type_from_size(C[i].refer.field->data.capacity(), 0);
+ tree dest_addr = gg_add(member(C[i].refer.field->var_decl_node,
"data"),
+ refer_offset(C[i].refer));
+ tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr);
+ if( format == giving_e )
+ {
+ // We are assigning
+ gg_assign( gg_indirect(ptr),
+ gg_cast(dest_type, sum));
+ }
+ else
+ {
+ // We are subtracting the sum from C[i]
+ gg_assign( gg_indirect(ptr),
+ gg_subtract(gg_indirect(ptr),
+ gg_cast(dest_type, sum)));
+ }
}
}
retval = true;
@@ -536,7 +760,7 @@ fast_multiply(size_t nC, cbl_num_result_t *C,
size_t nB, cbl_refer_t *B)
{
bool retval = false;
- if( all_results_binary(nC, C) )
+ if( all_results_integer(nC, C) )
{
Analyze();
// All targets are non-PICTURE binaries:
@@ -609,7 +833,7 @@ fast_divide(size_t nC, cbl_num_result_t *C,
const cbl_refer_t &remainder)
{
bool retval = false;
- if( all_results_binary(nC, C) )
+ if( all_results_integer(nC, C) )
{
Analyze();
// All targets are non-PICTURE binaries:
@@ -746,9 +970,9 @@ parser_add( size_t nC, cbl_num_result_t *C,
bool handled = false;
- if( fast_add( nC, C,
- nA, A,
- format) )
+ if( !error && !not_error && fast_add(nC, C,
+ nA, A,
+ format) )
{
handled = true;
}
@@ -1017,9 +1241,9 @@ parser_multiply(size_t nC, cbl_num_result_t *C,
SHOW_PARSE_END
}
- if( fast_multiply(nC, C,
- nA, A,
- nB, B) )
+ if( !error && !not_error && fast_multiply(nC, C,
+ nA, A,
+ nB, B) )
{
}
@@ -1108,10 +1332,10 @@ parser_divide( size_t nC, cbl_num_result_t *C,
// C = A / B
SHOW_PARSE_END
}
- if( fast_divide(nC, C,
- nA, A,
- nB, B,
- remainder) )
+ if( !error && !not_error && fast_divide(nC, C,
+ nA, A,
+ nB, B,
+ remainder) )
{
}
@@ -1441,10 +1665,10 @@ parser_subtract(size_t nC, cbl_num_result_t *C, //
C = B - A
bool handled = false;
- if( fast_subtract(nC, C,
- nA, A,
- nB, B,
- format) )
+ if( !error && !not_error && fast_subtract(nC, C,
+ nA, A,
+ nB, B,
+ format) )
{
handled = true;
}
diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc
index a143080542d..25f7b8070fa 100644
--- a/gcc/cobol/genutil.cc
+++ b/gcc/cobol/genutil.cc
@@ -744,17 +744,18 @@ get_data_offset(const cbl_refer_t &refer,
return retval;
}
-static tree tree_type_from_field(const cbl_field_t *field);
+//static tree tree_type_from_field(const cbl_field_t *field);
-void
-get_binary_value( tree value,
- tree rdigits,
- cbl_field_t *field,
- tree field_offset,
- tree hilo
- )
+tree
+get_binary_value_tree(tree return_type,
+ tree rdigits,
+ cbl_field_t *field,
+ tree field_offset,
+ tree hilo
+ )
{
- Analyze();
+ tree retval;
+
if( hilo )
{
gg_assign(hilo, integer_zero_node);
@@ -766,12 +767,12 @@ get_binary_value( tree value,
// Very special case:
if( strcmp(field->name, "ZEROS") == 0 )
{
- gg_assign(value, gg_cast(TREE_TYPE(value), integer_zero_node));
+ retval = gg_cast(return_type, integer_zero_node);
if( rdigits )
{
gg_assign(rdigits, gg_cast(TREE_TYPE(rdigits), integer_zero_node));
}
- return;
+ return retval;
}
static tree pointer = gg_define_variable( UCHAR_P,
@@ -781,7 +782,7 @@ get_binary_value( tree value,
{
case FldLiteralN:
{
- if( SCALAR_FLOAT_TYPE_P(value) )
+ if( return_type == FLOAT )
{
cbl_internal_error("cannot get %<float%> value from %s",
field->name);
}
@@ -792,21 +793,17 @@ get_binary_value( tree value,
gg_assign(rdigits, build_int_cst_type(TREE_TYPE(rdigits),
field->data.rdigits));
}
- tree dest_type = TREE_TYPE(value);
- tree source_type = tree_type_from_field(field);
-
- gg_assign(value,
- gg_cast(dest_type,
- gg_indirect(
gg_cast(build_pointer_type(source_type),
-
gg_get_address_of(field->data_decl_node)))));
+ // tree source_type = tree_type_from_field(field);
+ // retval = gg_cast(return_type,
+ // gg_indirect(
gg_cast(build_pointer_type(source_type),
+ //
gg_get_address_of(field->data_decl_node))));
+ retval = gg_cast(return_type, field->data_decl_node);
}
-
break;
}
case FldNumericDisplay:
{
- Analyzer.Message("FldNumericDisplay");
const charmap_t *charmap =
__gg__get_charmap(field->codeset.encoding);
int stride = charmap->stride();
@@ -829,14 +826,13 @@ get_binary_value( tree value,
build_int_cst_type( TREE_TYPE(rdigits),
get_scaled_rdigits(field)));
}
- gg_assign(value, build_int_cst_type(TREE_TYPE(value),
- 0x7FFFFFFFFFFFFFFFUL));
+ retval = build_int_cst_type(return_type, 0x7FFFFFFFFFFFFFFFUL);
}
ELSE
{
IF( digit, eq_op, build_int_cst(UCHAR, DEGENERATE_LOW_VALUE) )
{
- // We are dealing with LOW-VALUE
+ // We are dealing with LOW-VALUE
if( hilo )
{
gg_assign(hilo, integer_minus_one_node);
@@ -918,7 +914,10 @@ get_binary_value( tree value,
build_int_cst_type(INT,
field->codeset.encoding),
NULL_TREE));
// Assign the value we got from the string to our "return"
value:
- gg_assign(value, gg_cast(TREE_TYPE(value), val128));
+
+ // Note that cppcheck can't understand the run-time IF()
+ // cppcheck-suppress redundantAssignment
+ retval = gg_cast(return_type, val128);
}
ENDIF
}
@@ -931,10 +930,11 @@ get_binary_value( tree value,
{
// As of this writing, the source value is big-endian
// We have to convert it to a little-endian destination.
+ tree value = gg_define_variable(return_type);
tree dest = gg_cast(build_pointer_type(UCHAR),
gg_get_address_of(value));
tree source = get_data_address(field, field_offset);
- size_t dest_nbytes = gg_sizeof(value);
+ size_t dest_nbytes =
TREE_INT_CST_LOW(TYPE_SIZE_UNIT(return_type));
size_t source_nbytes = field->data.capacity();
if( debugging )
@@ -968,7 +968,7 @@ get_binary_value( tree value,
if( field->attr & signable_e )
{
IF( gg_array_value(gg_cast(build_pointer_type(SCHAR), source)),
- lt_op,
+ lt_op,
gg_cast(SCHAR, integer_zero_node) )
{
gg_assign(extension, build_int_cst_type(UCHAR, 0xFF));
@@ -1007,6 +1007,7 @@ get_binary_value( tree value,
hex_dump(dest, dest_nbytes);
gg_printf("\n", NULL_TREE);
}
+ retval = value;
break;
}
@@ -1035,7 +1036,6 @@ get_binary_value( tree value,
}
}
tree source_address = get_data_address(field, field_offset);
- tree dest_type = TREE_TYPE(value);
tree source_type = tree_type_from_size( field->data.capacity(),
field->attr & signable_e);
if( debugging && rdigits)
@@ -1043,10 +1043,9 @@ get_binary_value( tree value,
gg_printf("get_binary_value bin5 rdigits: %d\n", rdigits,
NULL_TREE);
}
- gg_assign(value,
- gg_cast(dest_type,
- gg_indirect(gg_cast(
build_pointer_type(source_type),
- source_address ))));
+ retval = gg_cast(return_type,
+ gg_indirect(gg_cast(
build_pointer_type(source_type),
+ source_address )));
break;
}
@@ -1058,17 +1057,16 @@ get_binary_value( tree value,
build_int_cst_type( TREE_TYPE(rdigits),
get_scaled_rdigits(field)));
}
- tree dest_type = TREE_TYPE(value);
-
- gg_assign(value,
- gg_cast(dest_type,
- gg_call_expr(INT128,
+ tree value = gg_define_variable(return_type);
+ gg_assign(value, gg_cast(return_type,
+ gg_call_expr(INT128,
"__gg__packed_to_binary",
get_data_address( field,
field_offset),
build_int_cst_type(INT,
field->data.capacity()),
NULL_TREE)));
+ retval = value;
break;
}
@@ -1080,13 +1078,14 @@ get_binary_value( tree value,
gg_assign(rdigits,
gg_cast( TREE_TYPE(rdigits), integer_zero_node));
}
- gg_assign(value,
- gg_cast(TREE_TYPE(value),
- gg_call_expr( INT128,
- "__gg__integer_from_float128",
-
gg_get_address_of(field->var_decl_node),
- NULL_TREE)));
+ tree value = gg_define_variable(return_type);
+ gg_assign(value, gg_cast(return_type,
+ gg_call_expr( INT128,
+ "__gg__integer_from_float128",
+
gg_get_address_of(field->var_decl_node),
+ NULL_TREE)));
needs_scaling = false;
+ retval = value;
break;
}
@@ -1108,18 +1107,70 @@ get_binary_value( tree value,
{
if( field->data.rdigits < 0 )
{
+ // Hey, Dubner!
+ // Should that test be != 0 rather than < 0? Maybe not; this
routine
+ // is supposed to be for integers.
+ tree value = gg_define_variable(return_type);
+ gg_assign(value, retval);
scale_by_power_of_ten_N(value, -field->data.rdigits);
+ retval = value;
}
}
}
+ return retval;
+ }
+
+tree
+get_binary_value_tree(tree return_type,
+ tree rdigits,
+ const cbl_refer_t &refer,
+ tree hilo
+ )
+ {
+ tree retval;
+ if( refer_is_clean(refer) )
+ {
+ retval = get_binary_value_tree(return_type,
+ rdigits,
+ refer.field,
+ integer_zero_node,
+ hilo);
+ }
+ else
+ {
+ retval = get_binary_value_tree(return_type,
+ rdigits,
+ refer.field,
+ refer_offset(refer),
+ hilo);
+ }
+ return retval;
+ }
+
+void
+get_binary_value( tree value,
+ tree rdigits,
+ cbl_field_t *field,
+ tree field_offset,
+ tree hilo
+ )
+ {
+ tree return_type = TREE_TYPE(value);
+ gg_assign(value, get_binary_value_tree( return_type,
+ rdigits,
+ field,
+ field_offset,
+ hilo ));
}
+#if 0
static tree
tree_type_from_field(const cbl_field_t *field)
{
gcc_assert(field);
return tree_type_from_size(field->data.capacity(), field->attr &
signable_e);
}
+#endif
tree
get_data_address( cbl_field_t *field,
@@ -1788,7 +1839,7 @@ refer_is_clean(const cbl_refer_t &refer)
// like.
return true;
}
-
+
return !refer.all
&& !refer.addr_of
&& !refer.nsubscript()
@@ -1989,3 +2040,61 @@ get_time_nanoseconds()
#endif
return retval;
}
+
+bool
+is_pure_integer(const cbl_field_t *field)
+ {
+ // Check to see if field is suitable for fast arithmetic. That is, it
is
+ // a native binary integer with no fixed-point decimal places:
+ bool retval = false;
+ switch( field->type )
+ {
+ case FldIndex:
+ case FldPointer:
+ case FldLiteralN:
+ retval = true;
+ break;
+
+ case FldNumericBin5:
+ if( !(field->attr & intermediate_e) && field->data.rdigits == 0 )
+ {
+ // This is a pure integer, with no rdigits
+ switch(field->data.capacity())
+ {
+ case 1:
+ case 2:
+ case 4:
+ case 8:
+ case 16:
+ // These are the sizes we know how to handle
+ retval = true;
+ break;
+ }
+ }
+ break;
+
+ case FldAlphanumeric:
+ if( strcmp(field->name, "ZEROS") == 0 )
+ {
+ retval = true;
+ }
+ break;
+
+ case FldInvalid:
+ case FldGroup:
+ case FldNumericBinary:
+ case FldFloat:
+ case FldPacked:
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ case FldLiteralA:
+ case FldClass:
+ case FldConditional:
+ case FldForward:
+ case FldSwitch:
+ case FldDisplay:
+ break;
+ }
+ return retval;
+ }
diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h
index f456f203ba5..3a2951e8175 100644
--- a/gcc/cobol/genutil.h
+++ b/gcc/cobol/genutil.h
@@ -91,6 +91,15 @@ void get_binary_value( tree value,
cbl_field_t *field,
tree field_offset,
tree hilo = NULL);
+tree get_binary_value_tree(tree return_type,
+ tree rdigits,
+ cbl_field_t *field,
+ tree field_offset,
+ tree hilo = NULL);
+tree get_binary_value_tree(tree return_type,
+ tree rdigits,
+ const cbl_refer_t &refer,
+ tree hilo = NULL);
tree get_data_address( cbl_field_t *field,
tree offset);
@@ -150,5 +159,6 @@ void build_array_of_fourplets( int ngroup,
void get_depending_on_value_from_odo(tree retval, cbl_field_t *odo);
uint64_t get_time_nanoseconds();
+bool is_pure_integer(const cbl_field_t *field);
#endif
diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc
index ea686ab9c4e..6229365284d 100644
--- a/gcc/cobol/symbols.cc
+++ b/gcc/cobol/symbols.cc
@@ -2295,7 +2295,8 @@ symbol_table_init(void) {
{ FldAlphanumeric, LOW_VALUE_E | constq | register_e,
{1,1,0,0, "L\0\xFF"}, 0, "LOW_VALUES", cp1252 },
{ FldAlphanumeric, ZERO_VALUE_E | constq | register_e,
- {1,1,0,0, "0"}, 0, "ZEROS", cp1252 },
+ {1,1,0,0, "0"}, 0, "ZEROS", cp1252 }, // Don't change "ZEROS";
there are
+ // things that depend on it.
{ FldAlphanumeric, HIGH_VALUE_E | constq | register_e,
{1,1,0,0, "H\0\xFF"}, 0, "HIGH_VALUES", cp1252 },
// IBM standard: QUOTE is a double-quote unless APOST compiler option
diff --git a/libgcobol/gfileio.cc b/libgcobol/gfileio.cc
index 144111ac0a6..884a145dbd5 100644
--- a/libgcobol/gfileio.cc
+++ b/libgcobol/gfileio.cc
@@ -4459,6 +4459,10 @@ __gg__file_reopen(cblc_file_t *file, int mode_char)
done:
file->prior_op = file_op_open;
+ // Call establish_status to raise exception if OPEN failed
+ // This ensures that if file->file_pointer is NULL, an exception is
raised
+ // Patch by George Neill of data-axle.com
+ establish_status(file, -1);
}
static void
diff --git a/libgcobol/gmath.cc b/libgcobol/gmath.cc
index 2078dbedca5..9419986d9be 100644
--- a/libgcobol/gmath.cc
+++ b/libgcobol/gmath.cc
@@ -731,7 +731,7 @@ __gg__fixed_phase2_assign_to_c( cbl_arith_format_t ,
int *compute_error
)
{
- // This is the assignment phase of an ADD Format 2
+ // This is the assignment phase of an ADD or SUBTRACT Format 2
cblc_field_t **C = __gg__treeplet_3f;
const size_t *C_o = __gg__treeplet_3o;
@@ -769,6 +769,15 @@ __gg__fixed_phase2_assign_to_c( cbl_arith_format_t ,
*compute_error |= compute_error_overflow;
}
+ if( C[0]->type == FldPointer )
+ {
+ // In case somebody does pointer arithmetic that goes negative, we
need
+ // to make the top 64 bits positive. Otherwise, the conditional
stash
+ // will see that FldPointer is not signable, and force the value
+ // positive with a two's complement.
+ value_a.i128[0] &= 0xFFFFFFFFFFFFFFFFUL;
+ }
+
// At this point, we assign that value to *C.
*compute_error |= conditional_stash(C[0], C_o[0], C_s[0],
on_size_error,
@@ -1056,7 +1065,7 @@ __gg__subtractf2_fixed_phase1(cbl_arith_format_t ,
on_error_flag,
compute_error);
- // Subtract that from the B value:
+ // Subtract the phase1_result from the B value:
int256 value_a = phase1_result;
int rdigits_a = phase1_rdigits;
@@ -1078,8 +1087,8 @@ __gg__subtractf2_fixed_phase1(cbl_arith_format_t ,
scale_int256_by_digits(value_a, rdigits_b - rdigits_a);
}
- // The two numbers have the same number of rdigits. It's now safe to
add
- // them.
+ // The two numbers have the same number of rdigits. It's now safe to
take
+ // the difference.
subtract_int256_from_int256(value_b, value_a);
int overflow = squeeze_int256(value_b, rdigits_b);
--
2.34.1
