https://gcc.gnu.org/g:9992c0a0e1b455ad5c68d7261b4bc9bfc2461f70
commit r16-3152-g9992c0a0e1b455ad5c68d7261b4bc9bfc2461f70
Author: Robert Dubner <rdub...@symas.com>
Date: Mon Aug 11 20:56:38 2025 -0400
cobol: Bring EBCDIC NumericDisplay variables into IBM compliance.
The internal representation of Numeric Display (ND) zoned decimal variables
when operating in EBCDIC mode has been brought into compliance with IBM
conventions. This requires changes to data input, data output, internal
conversion of zoned decimal to binary, and variable assignment.
gcc/cobol/ChangeLog:
* genapi.cc (compare_binary_binary): Formatting.
(cobol_compare): Formatting.
(mh_numeric_display): Rewrite "move ND to ND" algorithm.
(initial_from_initial): Proper initialization of EBCDIC ND
variables.
* genmath.cc (fast_add): Delete comment.
* genutil.cc (get_binary_value): Modify for updated EBCDIC.
libgcobol/ChangeLog:
* common-defs.h (NUMERIC_DISPLAY_SIGN_BIT): New comment; new
constant.
(EBCDIC_MINUS): New constant.
(EBCDIC_PLUS): Likewise.
(EBCDIC_ZERO): Likewise.
(EBCDIC_NINE): Likewise.
(PACKED_NYBBLE_PLUS): Likewise.
(PACKED_NYBBLE_MINUS): Likewise.
(PACKED_NYBBLE_UNSIGNED): Likewise.
(NUMERIC_DISPLAY_SIGN_BIT_ASCII): Likewise.
(NUMERIC_DISPLAY_SIGN_BIT_EBCDIC): Likewise.
(SEPARATE_PLUS): Likewise.
(SEPARATE_MINUS): Likewise.
(ZONED_ZERO): Likewise.
(ZONE_SIGNED_EBCDIC): Likewise.
* configure: Regenerate.
* libgcobol.cc (turn_sign_bit_on): Handle new EBCDIC sign
convention.
(turn_sign_bit_off): Likewise.
(is_sign_bit_on): Likewise.
(int128_to_field): EBCDIC NumericDisplay conversion.
(get_binary_value_local): Likewise.
(format_for_display_internal): Likewise.
(normalize_id): Likewise.
(__gg__inspect_format_1): Convert EBCDIC negative numbers to
positive.
* stringbin.cc (packed_from_combined): Quell cppcheck warning.
gcc/testsuite/ChangeLog:
*
cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out:
Change test for updated handling of Numeric Display variables.
Diff:
---
gcc/cobol/genapi.cc | 462 ++++++++-------------
gcc/cobol/genmath.cc | 1 -
gcc/cobol/genutil.cc | 104 ++---
...CATE_Rule_8_OPTION_INITIALIZE_with_figconst.out | 6 +-
libgcobol/common-defs.h | 53 ++-
libgcobol/configure | 1 -
libgcobol/libgcobol.cc | 360 +++++++++++-----
libgcobol/stringbin.cc | 2 +-
8 files changed, 527 insertions(+), 462 deletions(-)
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index c9d2da481ab9..40b79ba5ce6c 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -2102,6 +2102,7 @@ compare_binary_binary(tree return_int,
right_side_ref->field,
refer_offset(*right_side_ref),
hilo_right);
+
IF( hilo_left, eq_op, integer_one_node )
{
// left side is hi-value
@@ -2358,8 +2359,6 @@ cobol_compare( tree return_int,
NULL_TREE));
// compared = true; // Commented out to quiet cppcheck
}
-
-// gg_printf(" result is %d\n", return_int, NULL_TREE);
}
static void
@@ -14852,7 +14851,7 @@ static bool
mh_numeric_display( const cbl_refer_t &destref,
const cbl_refer_t &sourceref,
const TREEPLET &tsource,
- tree size_error)
+ tree size_error)
{
bool moved = false;
@@ -14862,98 +14861,106 @@ mh_numeric_display( const cbl_refer_t &destref,
&& !(sourceref.field->attr & scaled_e) )
{
Analyze();
- // I believe that there are 225 pathways through the following code.
That's
- // because there are five different valid combination of signable_e,
+ // I believe that there are 450 pathways through the following code.
+ // That's because there are five different valid combination of signable_e,
// separate_e, and leading_e. There are three possibilities for
- // sender/receiver rdigits (too many, too few, and just right), and the
same
- // for ldigits. 5 * 5 * 3 * 3 = 225.
+ // sender/receiver rdigits (too many, too few, and just right), and the
+ // same for ldigits. 5 * 5 * 3 * 3 * 2 = 450.
// Fasten your seat belts.
- // In order to simplify processing of a signable internal sender, we are
- // going to pick up the sign byte and temporarily turn off the sign bit in
- // the source data. At the end, we will restore that value. This
- // reflexively makes me a bit nervous (it isn't, for example, thread-safe),
- // but it makes life easier.
-
- static tree source_sign_loc = gg_define_variable(UCHAR_P,
"..mhnd_sign_loc", vs_file_static);
- static tree source_sign_byte = gg_define_variable(UCHAR,
"..mhnd_sign_byte", vs_file_static);
- static tree dest_p = gg_define_variable(UCHAR_P, "..mhnd_dest",
vs_file_static); // The destination data pointer
- static tree source_p = gg_define_variable(UCHAR_P, "..mhnd_source",
vs_file_static); // The source data pointer
- static tree source_ep = gg_define_variable(UCHAR_P, "..mhnd_source_e",
vs_file_static); // When we need an end pointer
+ // This routine is complicated by the fact that although I had several
+ // false starts of putting this into libgcobol, I keep coming back to the
+ // fact that assignment of zoned values is common. And, so, there are all
+ // kinds of things that are known at compile time that would turn into
+ // execution-time decisions if I moved them to the library. So, complex
+ // or not, I am doing all this code here at compile time because it will
+ // minimize the code at execution time.
+
+ // One thing to keep in mind is the problem caused by a source value being
+ // internally signed. That turns an ASCII "123" into "12t", and we
+ // very probably don't want that "t" to find its way into the destination
+ // value. The internal sign characteristic of ASCII is that the high
+ // nybble of the sign location is 0x30 or 0x70. For EBCDIC, the high
+ // nybble is 0xC0 for positive values, and 0xD0 for negative; all other
+ // digits are 0x70.
+
+ static tree source_sign_loc = gg_define_variable(UCHAR_P,
+ "..mhnd_sign_loc",
+ vs_file_static);
+ static tree source_sign_byte = gg_define_variable(UCHAR,
+ "..mhnd_sign_byte",
+ vs_file_static);
+ // The destination data pointer
+ static tree dest_p = gg_define_variable( UCHAR_P,
+ "..mhnd_dest",
+ vs_file_static);
+ // The source data pointer
+ static tree source_p = gg_define_variable( UCHAR_P,
+ "..mhnd_source",
+ vs_file_static);
+ // When we need an end pointer
+ static tree source_ep = gg_define_variable( UCHAR_P,
+ "..mhnd_source_e",
+ vs_file_static);
gg_assign(dest_p, qualified_data_location(destref));
gg_assign(source_p, gg_add(member(sourceref.field, "data"),
tsource.offset));
- if( sourceref.field->attr & signable_e )
+ bool source_is_signable = sourceref.field->attr & signable_e;
+ bool source_is_leading = sourceref.field->attr & leading_e;
+ bool source_is_separate = sourceref.field->attr & separate_e;
+
+ bool dest_is_signable = destref.field->attr & signable_e;
+ bool dest_is_leading = destref.field->attr & leading_e;
+ bool dest_is_separate = destref.field->attr & separate_e;
+
+ if( source_is_signable )
{
- // The source is signable
+ // The source is signable, so we are going to calculate the location of
+ // the source sign information.
+
+ gg_assign(source_sign_loc,
+ gg_add(member(sourceref.field->var_decl_node, "data"),
+ tsource.offset));
- if( !(sourceref.field->attr & leading_e) )
+ if( (source_is_leading) )
{
- // The sign location is trailing. Whether separate or not, the
location
- // is the final byte of the data:
- gg_assign(source_sign_loc, gg_add(member(
sourceref.field->var_decl_node, "data"),
- tsource.offset)),
- gg_assign(source_sign_loc,
- gg_add(source_sign_loc,
- build_int_cst_type(SIZE_T,
-
sourceref.field->data.capacity-1)));
- if( (sourceref.field->attr & separate_e) )
- {
- // We have trailing separate
- }
- else
+ // The source sign location is in the leading position.
+ if( source_is_separate )
{
- // We have trailing internal
+ // We have LEADING SEPARATE, so the first actual digit is at
+ // source_p+1.
+ gg_increment(source_p);
}
}
else
{
- // The source sign location is in the leading position.
+ // The sign location is trailing. Whether separate or not, the
+ // location is the final byte of the data:
gg_assign(source_sign_loc,
- gg_add(member(sourceref.field->var_decl_node, "data"),
- tsource.offset));
- if( (sourceref.field->attr & separate_e) )
- {
- // We have leading separate, so the first actual digit is at
- // source_p+1.
- gg_increment(source_p);
- }
- else
- {
- // We have leading internal
- }
+ gg_add(source_sign_loc,
+ build_int_cst_type(SIZE_T,
+ sourceref.field->data.capacity-1)));
}
// Pick up the byte that contains the sign data, whether internal or
// external:
gg_assign(source_sign_byte, gg_indirect(source_sign_loc));
- if( !(sourceref.field->attr & separate_e) )
+ if( !source_is_separate )
{
- // This is signable and internal, so we want to turn off the sign bit
- // in the original source data
- if( internal_codeset_is_ebcdic() )
- {
- gg_assign(gg_indirect(source_sign_loc),
- gg_bitwise_or(source_sign_byte,
- build_int_cst_type( UCHAR,
-
NUMERIC_DISPLAY_SIGN_BIT)));
- }
- else
- {
- gg_assign(gg_indirect(source_sign_loc),
- gg_bitwise_and( source_sign_byte,
- build_int_cst_type( UCHAR,
-
~NUMERIC_DISPLAY_SIGN_BIT)));
- }
+ // The source is signable and internal. We will modify the zone of
+ // the source sign byte to force it to be plain vanilla positive.
+
+ // When the move is done, we will replace that byte with the original
+ // value.
+ gg_assign(gg_indirect(source_sign_loc),
+ gg_bitwise_or(build_int_cst_type(UCHAR, ZONED_ZERO),
+ gg_bitwise_and( source_sign_byte,
+ build_int_cst_type( UCHAR,
0x0F))));
}
}
- else
- {
- // The number is unsigned, so do nothing.
- }
// Let the shenanigans begin.
@@ -14961,83 +14968,49 @@ mh_numeric_display( const cbl_refer_t &destref,
// The first thing to do is see if we need to output a leading sign
// character
- if( (destref.field->attr & signable_e)
- && (destref.field->attr & leading_e)
- && (destref.field->attr & separate_e) )
+ if( dest_is_signable
+ && dest_is_leading
+ && dest_is_separate )
{
// The output is signed, separate, and leading, so the first character
// needs to be either '+' or '-'
- if( (sourceref.field->attr & separate_e) )
+ if( source_is_separate )
{
- // The source is signable/separate
- // Oooh. Shiny. We already have that character.
+ // The source and dest are both signable/separate.
+ // Oooh. Shiny. We already have the sign character from the source,
+ // so we assign that to the destination.
gg_assign(gg_indirect(dest_p), source_sign_byte);
}
else
{
- // The source is internal. Not that up above we set source_sign_byte
- // even for source values that aren't signable
- if( internal_codeset_is_ebcdic() )
+ // The source is internal.
+ if( source_is_signable )
{
- // We are working in EBCDIC
- if( sourceref.field->attr & signable_e )
+ IF( gg_bitwise_and( source_sign_byte,
+ build_int_cst_type( UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)),
+ ne_op,
+ build_int_cst_type( UCHAR, 0) )
{
- IF( gg_bitwise_and( source_sign_byte,
- build_int_cst_type( UCHAR,
- NUMERIC_DISPLAY_SIGN_BIT)),
- eq_op,
- build_int_cst_type( UCHAR, 0) )
- {
- // The source was negative
- gg_assign(gg_indirect(dest_p),
- build_int_cst_type( UCHAR, EBCDIC_MINUS));
+ // The source was negative
+ gg_assign(gg_indirect(dest_p),
+ build_int_cst_type( UCHAR, SEPARATE_MINUS));
- }
- ELSE
- {
- // The source was positive
- gg_assign(gg_indirect(dest_p),
- build_int_cst_type( UCHAR, EBCDIC_PLUS));
- }
- ENDIF
}
- else
+ ELSE
{
- // The source is not signable, so the result is positive
+ // The source was positive
gg_assign(gg_indirect(dest_p),
- build_int_cst_type( UCHAR, EBCDIC_PLUS));
+ build_int_cst_type( UCHAR, SEPARATE_PLUS));
}
+ ENDIF
}
else
{
- // We are working in ASCII
- if( sourceref.field->attr & signable_e )
- {
- IF( gg_bitwise_and( source_sign_byte,
- build_int_cst_type( UCHAR,
- NUMERIC_DISPLAY_SIGN_BIT)),
- ne_op,
- build_int_cst_type( UCHAR, 0) )
- {
- // The source was negative
- gg_assign(gg_indirect(dest_p),
- build_int_cst_type( UCHAR, '-'));
-
- }
- ELSE
- {
- // The source was positive
- gg_assign(gg_indirect(dest_p),
- build_int_cst_type( UCHAR, '+'));
- }
- ENDIF
- }
- else
- {
- // The source is not signable, so the result is positive
- gg_assign(gg_indirect(dest_p),
- build_int_cst_type( UCHAR, '+'));
- }
+ // The source is not signable, so the signed becomes positive no
+ // matter what the sign of the source.
+ gg_assign(gg_indirect(dest_p),
+ build_int_cst_type( UCHAR, SEPARATE_PLUS));
}
}
gg_increment(dest_p);
@@ -15058,8 +15031,7 @@ mh_numeric_display( const cbl_refer_t &destref,
// The destination has more ldigits than the source, and needs some
// leading zeroes:
picky_memset( dest_p,
- internal_codeset_is_ebcdic() ?
- EBCDIC_ZERO : '0' ,
+ ZONED_ZERO ,
dest_ldigits - source_ldigits);
// With the leading zeros set, copy over the ldigits:
digit_count = source_ldigits;
@@ -15085,8 +15057,7 @@ mh_numeric_display( const cbl_refer_t &destref,
IF( gg_indirect(source_p),
ne_op,
build_int_cst_type( UCHAR,
- internal_codeset_is_ebcdic() ?
- EBCDIC_ZERO : '0') )
+ ZONED_ZERO) )
{
set_exception_code(ec_size_truncation_e);
gg_assign(size_error, integer_one_node);
@@ -15132,25 +15103,23 @@ mh_numeric_display( const cbl_refer_t &destref,
// over only the necessary rdigits, discarding the ones to the right.
digit_count += dest_rdigits;
}
-
picky_memcpy(dest_p, source_p, digit_count);
picky_memset( dest_p,
- internal_codeset_is_ebcdic() ?
- EBCDIC_ZERO : '0' ,
+ ZONED_ZERO ,
trailing_zeros);
// With the digits in place, we need to sort out what to do if the target
// is signable:
- if( destref.field->attr & signable_e )
+ if( dest_is_signable )
{
- if( (destref.field->attr & separate_e)
- && !(destref.field->attr & leading_e) )
+ if( dest_is_separate
+ && !dest_is_leading )
{
// The target is separate/trailing, so we need to tack a '+'
// or '-' character
- if( sourceref.field->attr & separate_e )
+ if( source_is_separate )
{
- // The source was separate, so we already have what we need in t
+ // The source was separate, so we already have what we need in the
// source_sign_byte:
gg_assign(gg_indirect(dest_p), source_sign_byte);
gg_increment(dest_p);
@@ -15158,68 +15127,43 @@ mh_numeric_display( const cbl_refer_t &destref,
else
{
// The source is either internal, or unsigned
- if( sourceref.field->attr & signable_e )
+ if( source_is_signable )
{
// The source is signable/internal, so we need to extract the
// sign bit from source_sign_byte
- if( internal_codeset_is_ebcdic() )
+ IF( gg_bitwise_and( source_sign_byte,
+ build_int_cst_type( UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)),
+ ne_op,
+ build_int_cst_type( UCHAR, 0) )
{
- IF( gg_bitwise_and( source_sign_byte,
- build_int_cst_type( UCHAR,
-
NUMERIC_DISPLAY_SIGN_BIT)),
- eq_op,
- build_int_cst_type( UCHAR, 0) )
- {
- // The source was negative
- gg_assign(gg_indirect(dest_p),
- build_int_cst_type( UCHAR, EBCDIC_MINUS));
+ // The source was negative
+ gg_assign(gg_indirect(dest_p),
+ build_int_cst_type( UCHAR, SEPARATE_MINUS));
- }
- ELSE
- {
- // The source was positive
- gg_assign(gg_indirect(dest_p),
- build_int_cst_type( UCHAR, EBCDIC_PLUS));
- }
- ENDIF
}
- else
+ ELSE
{
- IF( gg_bitwise_and( source_sign_byte,
- build_int_cst_type( UCHAR,
-
NUMERIC_DISPLAY_SIGN_BIT)),
- ne_op,
- build_int_cst_type( UCHAR, 0) )
- {
- // The source was negative
- gg_assign(gg_indirect(dest_p),
- build_int_cst_type( UCHAR, '-'));
-
- }
- ELSE
- {
- // The source was positive
- gg_assign(gg_indirect(dest_p),
- build_int_cst_type( UCHAR, '+'));
- }
- ENDIF
+ // The source was positive
+ gg_assign(gg_indirect(dest_p),
+ build_int_cst_type( UCHAR, SEPARATE_PLUS));
}
+ ENDIF
}
else
{
// The source is unsigned, so dest is positive
gg_assign(gg_indirect(dest_p),
build_int_cst_type( UCHAR,
- internal_codeset_is_ebcdic() ?
- EBCDIC_PLUS : '+' ));
+ SEPARATE_PLUS));
}
}
gg_increment(dest_p);
}
- else if( !(destref.field->attr & separate_e) )
+ else if( !dest_is_separate )
{
// The destination is signed/internal
- if( destref.field->attr & leading_e )
+ if( dest_is_leading )
{
// The sign bit goes into the first byte:
gg_assign(dest_p, qualified_data_location(destref));
@@ -15229,104 +15173,62 @@ mh_numeric_display( const cbl_refer_t &destref,
// The sign bit goes into the last byte:
gg_decrement(dest_p);
}
- if( sourceref.field->attr & signable_e )
+ // dest_p now points to the internal sign location
+ if( internal_codeset_is_ebcdic() )
{
- if( sourceref.field->attr & separate_e )
+ // For EBCDIC, the zone is going to end up being 0xC0 or 0xD0
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_and(gg_indirect(dest_p),
+ build_int_cst_type(UCHAR,
+
ZONE_SIGNED_EBCDIC+0x0F)));
+ }
+
+ if( source_is_signable )
+ {
+ if( source_is_separate )
{
// The source is separate, so source_sign_byte is '+' or '-'
IF( source_sign_byte,
eq_op,
- build_int_cst_type(UCHAR,
- internal_codeset_is_ebcdic() ?
- EBCDIC_MINUS : '-') )
+ build_int_cst_type(UCHAR, SEPARATE_MINUS) )
{
- // The source is negative, so turn the ASCII bit on
- if( !internal_codeset_is_ebcdic() )
- {
- gg_assign(gg_indirect(dest_p),
- gg_bitwise_or(gg_indirect(dest_p),
- build_int_cst_type(
- UCHAR,
- NUMERIC_DISPLAY_SIGN_BIT)));
-
- }
- else
- {
- // It's ebcdic, so turn the sign bit OFF
- gg_assign(gg_indirect(dest_p),
- gg_bitwise_and(gg_indirect(dest_p),
- build_int_cst_type(
- UCHAR,
- ~NUMERIC_DISPLAY_SIGN_BIT)));
- }
+ // The source is negative, so turn on the internal "is minus" bit
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_or(gg_indirect(dest_p),
+ build_int_cst_type(
+ UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)));
}
ELSE
- {
- // The source is positive, so turn the EBCDIC bit ON:
- if( internal_codeset_is_ebcdic() )
- {
- gg_assign(gg_indirect(dest_p),
- gg_bitwise_or(gg_indirect(dest_p),
- build_int_cst_type(
- UCHAR,
- NUMERIC_DISPLAY_SIGN_BIT)));
- }
- }
ENDIF
}
else
{
// The source is signable/internal, so the sign bit is in
// source_sign_byte. Whatever it is, it has to go into dest_p:
- if( internal_codeset_is_ebcdic() )
- {
- // This is EBCDIC, so if the source_sign_byte bit is LOW, we
- // clear that bit in dest_p high.
- IF( gg_bitwise_and( source_sign_byte,
- build_int_cst_type(
- UCHAR,
- NUMERIC_DISPLAY_SIGN_BIT)),
- eq_op,
- build_int_cst_type(UCHAR, 0) )
- {
- // The source was negative, so make the dest negative
- gg_assign(gg_indirect(dest_p),
- gg_bitwise_and(gg_indirect(dest_p),
- build_int_cst_type(
- UCHAR,
- ~NUMERIC_DISPLAY_SIGN_BIT)));
- }
- ELSE
- ENDIF
- }
- else
+ IF( gg_bitwise_and( source_sign_byte,
+ build_int_cst_type(
+ UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)),
+ ne_op,
+ build_int_cst_type(UCHAR, 0) )
{
- // This is ASCII, so if the source_sign_byte bit is high, we
- // set that bit in dest_p high.
- IF( gg_bitwise_and( source_sign_byte,
- build_int_cst_type(
- UCHAR,
- NUMERIC_DISPLAY_SIGN_BIT)),
- ne_op,
- build_int_cst_type(UCHAR, 0) )
- {
- // The source was negative, so make the dest negative
- gg_assign(gg_indirect(dest_p),
- gg_bitwise_or(gg_indirect(dest_p),
- build_int_cst_type(
- UCHAR,
- NUMERIC_DISPLAY_SIGN_BIT)));
- }
- ELSE
- ENDIF
+ // The source was negative, so make the dest negative
+ gg_assign(gg_indirect(dest_p),
+ gg_bitwise_or(gg_indirect(dest_p),
+ build_int_cst_type(
+ UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)));
}
+ ELSE
+ ENDIF
}
}
}
}
- if( (sourceref.field->attr & signable_e)
- && !(sourceref.field->attr & separate_e))
+ if( source_is_signable
+ && !source_is_separate)
{
// The source is signable internal, so we need to restore the original
// sign byte in the original source data:
@@ -15335,7 +15237,7 @@ mh_numeric_display( const cbl_refer_t &destref,
moved = true;
}
return moved;
- }
+ } //NUMERIC_DISPLAY_SIGN
static bool
mh_little_endian( const cbl_refer_t &destref,
@@ -16068,12 +15970,12 @@ initial_from_initial(cbl_field_t *field)
bool negative;
if( real_isneg (&value) )
{
- negative = true;
- value = real_value_negate (&value);
+ negative = true;
+ value = real_value_negate (&value);
}
else
{
- negative = false;
+ negative = false;
}
digits_from_float128(ach, field, field->data.digits, rdigits, value);
@@ -16083,6 +15985,7 @@ initial_from_initial(cbl_field_t *field)
&& (field->attr & separate_e)
&& (field->attr & leading_e ) )
{
+ // This zoned decimal value is signable, separate, and leading.
if( negative )
{
*pretval++ = internal_minus;
@@ -16094,12 +15997,14 @@ initial_from_initial(cbl_field_t *field)
}
for(size_t i=0; i<field->data.digits; i++)
{
+ // Start by assuming its an value that can't be signed
*pretval++ = internal_zero + ((*digits++) & 0x0F);
}
if( (field->attr & signable_e)
&& (field->attr & separate_e)
&& !(field->attr & leading_e ) )
{
+ // The value is signable, separate, and trailing
if( negative )
{
*pretval++ = internal_minus;
@@ -16110,30 +16015,21 @@ initial_from_initial(cbl_field_t *field)
}
}
if( (field->attr & signable_e)
- && !(field->attr & separate_e)
- && negative)
+ && !(field->attr & separate_e) )
{
- if( field->attr & leading_e )
+ // This value is signable, and not separate. So, the sign information
+ // goes into the first or last byte:
+ char *sign_location = field->attr & leading_e ?
+ retval : retval + field->data.digits - 1 ;
+ if( internal_codeset_is_ebcdic() )
{
- if( internal_is_ebcdic )
- {
- retval[0] &= ~NUMERIC_DISPLAY_SIGN_BIT;
- }
- else
- {
- retval[0] |= NUMERIC_DISPLAY_SIGN_BIT;
- }
+ // Change the zone from 0xFO to 0xC0
+ *sign_location &= (ZONE_SIGNED_EBCDIC + 0x0F);
}
- else
+ if( negative )
{
- if( internal_is_ebcdic )
- {
- pretval[-1] &= ~NUMERIC_DISPLAY_SIGN_BIT;
- }
- else
- {
- pretval[-1] |= NUMERIC_DISPLAY_SIGN_BIT;
- }
+ // Turn on the sign bit:
+ *sign_location |= NUMERIC_DISPLAY_SIGN_BIT;
}
}
break;
diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc
index e7eb971d1acb..27d5c1ee65fc 100644
--- a/gcc/cobol/genmath.cc
+++ b/gcc/cobol/genmath.cc
@@ -394,7 +394,6 @@ fast_add( size_t nC, cbl_num_result_t *C,
{
Analyze();
// All targets are non-PICTURE binaries:
- //gg_insert_into_assembler("# DUBNER addition START");
tree term_type = largest_binary_term(nA, A);
if( term_type )
{
diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc
index a5f69a09eec9..1c39ff19f338 100644
--- a/gcc/cobol/genutil.cc
+++ b/gcc/cobol/genutil.cc
@@ -858,57 +858,47 @@ get_binary_value( tree value,
// The sign byte is internal
if( field->attr & leading_e)
{
- // The first byte has the sign bit:
+ // The first byte has the sign bit. We need to turn it off,
+ // to make the value positive:
gg_assign(signbyte,
gg_get_indirect_reference(source_address,
NULL_TREE));
- if( internal_codeset_is_ebcdic() )
- {
- // We need to make sure the EBCDIC sign bit is ON, for
positive
- gg_assign(gg_get_indirect_reference(source_address,
NULL_TREE),
- gg_bitwise_or(signbyte,
+ // We need to make sure the ascii sign bit is off, for positive
+ gg_assign(gg_get_indirect_reference(source_address, NULL_TREE),
+ gg_bitwise_and( signbyte,
build_int_cst_type( UCHAR,
-
NUMERIC_DISPLAY_SIGN_BIT)));
- }
- else
- {
- // We need to make sure the ascii sign bit is Off, for
positive
- gg_assign(gg_get_indirect_reference(source_address,
NULL_TREE),
- gg_bitwise_and( signbyte,
- build_int_cst_type( UCHAR,
-
~NUMERIC_DISPLAY_SIGN_BIT)));
- }
+
~NUMERIC_DISPLAY_SIGN_BIT)));
}
else
{
- // The final byte has the sign bit:
+ // The final byte has the sign bit. We need to turn it off,
+ // to make the value positive:
gg_assign(signbyte,
gg_get_indirect_reference(source_address,
build_int_cst_type(SIZE_T,
field->data.capacity-1)));
- if( internal_codeset_is_ebcdic() )
- {
- // We need to make sure the EBCDIC sign bit is ON, for
positive
- gg_assign(gg_get_indirect_reference(source_address,
- build_int_cst_type(
SIZE_T,
-
field->data.capacity-1)),
- gg_bitwise_or(signbyte,
+ gg_assign(gg_get_indirect_reference(source_address,
+ build_int_cst_type( SIZE_T,
+
field->data.capacity-1)),
+ gg_bitwise_and( signbyte,
build_int_cst_type( UCHAR,
-
NUMERIC_DISPLAY_SIGN_BIT)));
- }
- else
- {
- // We need to make sure the ASCII sign bit is Off, for
positive
- gg_assign(gg_get_indirect_reference(source_address,
- build_int_cst_type(
SIZE_T,
-
field->data.capacity-1)),
- gg_bitwise_and( signbyte,
- build_int_cst_type( UCHAR,
-
~NUMERIC_DISPLAY_SIGN_BIT)));
- }
+
~NUMERIC_DISPLAY_SIGN_BIT)));
}
}
}
// We can now set up the byte-by-byte processing loop:
+ WHILE( pointer, lt_op, pend )
+ {
+ // Pick up the byte
+ digit = gg_get_indirect_reference(pointer, NULL_TREE);
+ // Whether ASCII or EBCDIC, the bottom four bits tell the tale:
+ // Multiply our accumulator by ten:
+ gg_assign(value, gg_multiply(value,
build_int_cst_type(TREE_TYPE(value), 10)));
+ // And add in the current digit
+ gg_assign(value, gg_add(value, gg_cast(TREE_TYPE(value),
gg_bitwise_and(digit, build_int_cst_type(UCHAR, 0x0F)))));
+ gg_increment(pointer);
+ }
+ WEND
+#if 0
if( internal_codeset_is_ebcdic() )
{
// We are working in EBCDIC
@@ -961,6 +951,7 @@ get_binary_value( tree value,
}
WEND
}
+#endif
// Value contains the binary value. The last thing is to apply --
and
// undo -- the signable logic:
@@ -1004,10 +995,12 @@ get_binary_value( tree value,
// The final byte is '+' or '-'
if( internal_codeset_is_ebcdic() )
{
- // We are operating in EBCDIC, so we look for a 96 (is minus
sign)
- IF( gg_get_indirect_reference(source_address,
build_int_cst_type(SIZE_T, field->data.capacity-1)),
- eq_op,
- build_int_cst_type(UCHAR, 96) )
+ // We are operating in EBCDIC
+ IF( gg_get_indirect_reference(source_address,
+ build_int_cst_type(SIZE_T,
+ field->data.capacity-1)),
+ eq_op,
+ build_int_cst_type(UCHAR, EBCDIC_MINUS) )
{
gg_assign(value, gg_negate(value));
}
@@ -1031,30 +1024,17 @@ get_binary_value( tree value,
else
{
// The sign byte is internal. Check the sign bit
- if(internal_codeset_is_ebcdic())
+ IF( gg_bitwise_and(signbyte,
+ build_int_cst_type(UCHAR,
+ NUMERIC_DISPLAY_SIGN_BIT)),
+ ne_op,
+ build_int_cst_type(UCHAR, 0) )
{
- IF( gg_bitwise_and( signbyte,
- build_int_cst_type( UCHAR,
-
NUMERIC_DISPLAY_SIGN_BIT)), eq_op, build_int_cst_type(UCHAR, 0) )
- {
- // The EBCDIC sign bit was OFF, so negate the result
- gg_assign(value, gg_negate(value));
- }
- ELSE
- ENDIF
- }
- else
- {
- IF( gg_bitwise_and( signbyte,
- build_int_cst_type( UCHAR,
-
NUMERIC_DISPLAY_SIGN_BIT)), ne_op, build_int_cst_type(UCHAR, 0) )
- {
- // The ASCII sign bit was on, so negate the result
- gg_assign(value, gg_negate(value));
- }
- ELSE
- ENDIF
+ // The ASCII sign bit was on, so negate the result
+ gg_assign(value, gg_negate(value));
}
+ ELSE
+ ENDIF
// It's time to put back the original data:
if( field->attr & leading_e)
{
diff --git
a/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out
b/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out
index ea05e96cfb31..15e06d1d0345 100644
---
a/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out
+++
b/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out
@@ -1,15 +1,15 @@
initialize zeroes
allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise
defaultbyte, otherwise zero)
(1) as allocated
- "" "" 0x0000000000000000
+ "" "000" 0x0000000000000000
initialize low-value
allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise
defaultbyte, otherwise zero)
(1) as allocated
- "" "" 0x0000000000000000
+ "" "000" 0x0000000000000000
initialize spaces
allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise
defaultbyte, otherwise zero)
(1) as allocated
- " " " " 0x2020202020202020
+ " " "000" 0x2020202020202020
initialize high-value
allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise
defaultbyte, otherwise zero)
0xffffffffffffffff
diff --git a/libgcobol/common-defs.h b/libgcobol/common-defs.h
index 15d06831be74..80e524c1e666 100644
--- a/libgcobol/common-defs.h
+++ b/libgcobol/common-defs.h
@@ -52,12 +52,53 @@
// COBOL tables can have up to seven subscripts
#define MAXIMUM_TABLE_DIMENSIONS 7
-// This bit gets turned on in the first or last byte (depending on the
leading_e attribute
-// phrase) of a NumericDisplay to indicate that the value is negative.
-
-// When running the EBCDIC character set, the meaning of this bit is flipped,
-// because an EBCDIC zero is 0xF0, while ASCII is 0x30
-#define NUMERIC_DISPLAY_SIGN_BIT 0x40
+/* COBOL has the concept of Numeric Display values, which use an entire byte
+ per digit. IBM also calls this "Zoned Decimal".
+
+ In ASCII, the digits are '0' through '9' (0x30 through 0x39'. Signed
+ values are indicated by turning on the 0x40 bit in either the first
+ byte (for LEADING variables) or the last byte (for TRAILING).
+
+ In IBM EBCDIC, the representation is slightly more complex, because the
+ concept of Zone carries a little more information. Unsigned numbers are
+ made up of just the EBCDIC digits '0' through '9' (0xF0 through 0xF9).
+
+ The TRAILING signed value +1234 has the byte sequence 0xF1 0xF2 0xF3 0xC3.
+ The TRAILING signed value -1234 has the byte sequence 0xF1 0xF2 0xF3 0xD3.
+ The LEADING signed value +1234 has the byte sequence 0xC1 0xF2 0xF3 0xF3.
+ The LEADING signed value -1234 has the byte sequence 0xD1 0xF2 0xF3 0xF3.
+
+ Note that for IBM EBCDIC, the nybble indicating sign has the same meaning
+ as for COMP-3/packed-decimal numbers.
+
+ The effective result of this is that for ASCII, the byte carrying the sign
+ is made negative by turning on the 0x40 bit.
+
+ For EBCDIC, the value must be constructed properly as a positive value by
+ setting the high nybble of the sign-carrying byte to 0xC0, after which the
+ value is flagged negative by turning on the 0x10 bit, turning the 0xC0 to
+ 0xD0. */
+
+#define EBCDIC_MINUS (0x60)
+#define EBCDIC_PLUS (0x4E)
+#define EBCDIC_ZERO (0xF0)
+#define EBCDIC_NINE (0xF9)
+
+#define PACKED_NYBBLE_PLUS 0x0C
+#define PACKED_NYBBLE_MINUS 0x0D
+#define PACKED_NYBBLE_UNSIGNED 0x0F
+
+#define NUMERIC_DISPLAY_SIGN_BIT_ASCII 0x40
+#define NUMERIC_DISPLAY_SIGN_BIT_EBCDIC 0x10
+
+#define NUMERIC_DISPLAY_SIGN_BIT (__gg__ebcdic_codeset_in_use ? \
+ NUMERIC_DISPLAY_SIGN_BIT_EBCDIC : \
+ NUMERIC_DISPLAY_SIGN_BIT_ASCII)
+
+#define SEPARATE_PLUS (__gg__ebcdic_codeset_in_use ? EBCDIC_PLUS : '+')
+#define SEPARATE_MINUS (__gg__ebcdic_codeset_in_use ? EBCDIC_MINUS : '-')
+#define ZONED_ZERO (__gg__ebcdic_codeset_in_use ? EBCDIC_ZERO : '0')
+#define ZONE_SIGNED_EBCDIC (0xC0)
#define LEVEL01 (1)
#define LEVEL49 (49)
diff --git a/libgcobol/configure b/libgcobol/configure
index d130002b2b95..72715177c230 100755
--- a/libgcobol/configure
+++ b/libgcobol/configure
@@ -16019,7 +16019,6 @@ fi
-
use_additional=yes
acl_save_prefix="$prefix"
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index eac6e3164198..b46fd13f2080 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -971,11 +971,11 @@ turn_sign_bit_on(unsigned char *location)
{
if( internal_is_ebcdic )
{
- *location &= ~NUMERIC_DISPLAY_SIGN_BIT;
+ *location = (*location & 0xF) + 0xD0;
}
else
{
- *location |= NUMERIC_DISPLAY_SIGN_BIT;
+ *location = (*location & 0xF) + 0x70;
}
}
@@ -984,11 +984,11 @@ turn_sign_bit_off(unsigned char *location)
{
if( internal_is_ebcdic )
{
- *location |= NUMERIC_DISPLAY_SIGN_BIT;
+ *location = (*location & 0xF) + 0xF0;
}
else
{
- *location &= ~NUMERIC_DISPLAY_SIGN_BIT;
+ *location = (*location & 0xF) + 0x30;
}
}
@@ -1003,14 +1003,7 @@ is_sign_bit_on(char ch)
}
else
{
- if( internal_is_ebcdic )
- {
- retval = (ch & NUMERIC_DISPLAY_SIGN_BIT) == 0;
- }
- else
- {
- retval = (ch & NUMERIC_DISPLAY_SIGN_BIT) != 0;
- }
+ retval = (ch & NUMERIC_DISPLAY_SIGN_BIT) != 0;
}
return retval;
}
@@ -1581,6 +1574,9 @@ int128_to_field(cblc_field_t *var,
case FldNumericDisplay:
if( var->attr & signable_e )
{
+ /* There is a regrettable plethora of possibilities, here. */
+
+
// Things get exciting when a numeric-display value is signable
if( var->attr & separate_e )
@@ -1592,7 +1588,8 @@ int128_to_field(cblc_field_t *var,
// The sign character goes into the first location
size_error =
__gg__binary_to_string_internal(PTRCAST(char, location+1),
- length-1, value);
+ length-1,
+ value);
location[0] = sign_ch;
}
else
@@ -1606,12 +1603,21 @@ int128_to_field(cblc_field_t *var,
}
else
{
- // The sign information is not separate, so we put it into
- // the number
+ /* The sign information is not separate. The sign information
+ goes into the first byte for LEADING, or the last byte for
+ TRAILING. For ASCII, the zone will be 0x30. For EBCDIC,
+ the the zone is 0xC0. Those get modified, respectively, to
+ 0x70 and 0xD0 when the value is negative. */
+
+ // First, convert the binary value to the correct-length string
size_error =
__gg__binary_to_string_internal(PTRCAST(char, location),
- length, value);
+ length,
+ value);
+ // Check for a size error on a negative value. It conceivably
+ // was truncated down to zero, in which case we need to
+ // suppress this is_negative flag.
if( size_error && is_negative )
{
// If all of the digits are zero, then the result is zero,
and
@@ -1627,27 +1633,28 @@ int128_to_field(cblc_field_t *var,
}
}
+ unsigned char *sign_location =
+ var->attr & leading_e ? location : location + length - 1;
+
+ if( internal_is_ebcdic )
+ {
+ // Change the sign location from 0xF0 to 0xC0.
+ *sign_location &= (ZONE_SIGNED_EBCDIC + 0xF);
+ }
+
if( is_negative )
{
- if( var->attr & leading_e )
- {
- // The sign bit goes into the first digit:
- turn_sign_bit_on(&location[0]);
- }
- else
- {
- // The sign bit goes into the last digit:
- turn_sign_bit_on(&location[length-1]);
- }
+ *sign_location |= NUMERIC_DISPLAY_SIGN_BIT;
}
}
}
else
{
// It's a simple positive number
- size_error = __gg__binary_to_string_internal( PTRCAST(char,
- location),
- length, value);
+ size_error = __gg__binary_to_string_internal(
+ PTRCAST(char, location),
+ length,
+ value);
}
break;
@@ -1985,10 +1992,8 @@ get_binary_value_local( int *rdigits,
{
__int128 retval = 0;
- unsigned char ch;
switch( resolved_var->type )
{
-#if 1
case FldLiteralA :
fprintf(stderr, "%s(): is trying to handle a FldLiteralA\n", __func__);
abort();
@@ -1997,7 +2002,6 @@ get_binary_value_local( int *rdigits,
// resolved_length,
// rdigits );
break;
-#endif
case FldGroup :
case FldAlphanumeric :
@@ -2008,7 +2012,8 @@ get_binary_value_local( int *rdigits,
rdigits );
break;
- case FldNumericDisplay :
+ case FldNumericDisplay:
+ {
if( resolved_location[resolved_length-1] == DEGENERATE_HIGH_VALUE )
{
// This is a degenerate case, which violates the language
@@ -2036,53 +2041,142 @@ get_binary_value_local( int *rdigits,
}
else
{
- // Pick up the sign byte, and force our value to be positive
unsigned char *sign_byte_location;
- if( (resolved_var->attr & separate_e )
- && (resolved_var->attr & leading_e ) )
+ unsigned char ch;
+ if( resolved_var->attr & signable_e )
{
- sign_byte_location = resolved_location;
- ch = *sign_byte_location;
- *sign_byte_location = internal_plus;
- }
- else if( (resolved_var->attr & separate_e)
- && !(resolved_var->attr & leading_e ) )
- {
- sign_byte_location = resolved_location + resolved_length - 1;
- ch = *sign_byte_location;
- *sign_byte_location = internal_plus;
+ // Pick up the sign byte, and force our value to be positive
+ if( (resolved_var->attr & separate_e )
+ && (resolved_var->attr & leading_e ) )
+ {
+ // LEADING SEPARATE
+ sign_byte_location = resolved_location;
+ resolved_location += 1;
+ resolved_length -= 1;
+ ch = *sign_byte_location;
+ *sign_byte_location = internal_plus;
+ }
+ else if( (resolved_var->attr & separate_e)
+ && !(resolved_var->attr & leading_e ) )
+ {
+ // TRAILING SEPARATE
+ sign_byte_location = resolved_location + resolved_length - 1;
+ resolved_length -= 1;
+ ch = *sign_byte_location;
+ *sign_byte_location = internal_plus;
+ }
+ else if( (resolved_var->attr & leading_e) )
+ {
+ // LEADING
+ sign_byte_location = resolved_location;
+ ch = *sign_byte_location;
+ turn_sign_bit_off(sign_byte_location);
+ }
+ else // if( !(resolved_var->attr & leading_e) )
+ {
+ // TRAILING
+ sign_byte_location = resolved_location + resolved_length - 1;
+ ch = *sign_byte_location;
+ turn_sign_bit_off(sign_byte_location);
+ }
}
- else if( (resolved_var->attr & leading_e) )
- {
- sign_byte_location = resolved_location;
- ch = *sign_byte_location;
- turn_sign_bit_off(sign_byte_location);
+
+ // We know where the decimal point is because of rdigits. Because
+ // we know that we have a clean string of digits (either ASCII or
+ // EBCDIC), we can just build up the result:
+
+ static const uint8_t from_ebcdic[256] =
+ {
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x00
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x10
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x20
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x30
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x40
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x50
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x60
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x70
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x80
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x90
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xa0
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xb0
+ 0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0, // 0xc0
+ 0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0, // 0xd0
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xe0
+ 0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0, // 0xf0
+ };
+
+ static const uint8_t from_ascii[256] =
+ {
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x00
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x10
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x20
+ 0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0, // 0x30
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x40
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x50
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x60
+ 0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0, // 0x70
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x80
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0x90
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xa0
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xb0
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xc0
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xd0
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xe0
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 0xf0
+ };
+
+ if( internal_is_ebcdic )
+ {
+ for(size_t i=0; i<resolved_length; i++)
+ {
+ retval *= 10;
+ retval += from_ebcdic[resolved_location[i]];
+ }
}
- else // if( !(resolved_var->attr & leading_e) )
+ else
{
- sign_byte_location = resolved_location + resolved_length - 1;
- ch = *sign_byte_location;
- turn_sign_bit_off(sign_byte_location);
+ for(size_t i=0; i<resolved_length; i++)
+ {
+ retval *= 10;
+ retval += from_ascii[resolved_location[i]];
+ }
}
- // We know where the decimal point is because of rdigits. Because
- // we know that it a clean string of ASCII digits, we can use the
- // dirty converter:
- retval = __gg__dirty_to_binary_internal(PTRCAST(const char,
- resolved_location),
- resolved_length,
- rdigits );
*rdigits = resolved_var->rdigits;
- // Restore the sign byte
- *sign_byte_location = ch;
-
- if( ch == internal_minus || is_sign_bit_on(ch) )
+ if( resolved_var->attr & signable_e )
{
- retval = -retval;
+ // Restore the sign byte
+ *sign_byte_location = ch;
+
+ // And if the source is flagged negative, make our result negative
+ if( ch == internal_minus )
+ {
+ retval = -retval;
+ }
+ else
+ {
+ if( internal_is_ebcdic )
+ {
+ // EBCDIC characters:
+ if( (ch & 0xF0) == 0xD0 )
+ {
+ retval = -retval;
+ }
+ }
+ else
+ {
+ // ASCII characters:
+ if( (ch & 0xF0) == 0x70 )
+ {
+ retval = -retval;
+ }
+ }
+ }
}
}
break;
+ }
case FldNumericEdited :
retval = edited_to_binary( PTRCAST(char, resolved_location),
@@ -3024,6 +3118,47 @@ format_for_display_internal(char **dest,
case FldNumericDisplay:
{
+ // Because a NumericDisplay can have any damned thing as a character,
+ // we are going force things that aren't digits to display as '0'
+ static const uint8_t ascii_chars[256] =
+ {
+ '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0',
'0', '0', // 0x00
+ '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0',
'0', '0', // 0x10
+ '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0',
'0', '0', // 0x20
+ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '0', '0', '0', '0',
'0', '0', // 0x30
+ '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0',
'0', '0', // 0x40
+ '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0',
'0', '0', // 0x50
+ '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0',
'0', '0', // 0x60
+ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '0', '0', '0', '0',
'0', '0', // 0x70
+ '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0',
'0', '0', // 0x80
+ '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0',
'0', '0', // 0x90
+ '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0',
'0', '0', // 0xa0
+ '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0',
'0', '0', // 0xb0
+ '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0',
'0', '0', // 0xc0
+ '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0',
'0', '0', // 0xd0
+ '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0',
'0', '0', // 0xe0
+ '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0', '0',
'0', '0', // 0xf0
+ };
+ static const uint8_t ebcdic_chars[256] =
+ {
+
0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,
// 0x00
+
0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,
// 0x10
+
0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,
// 0x20
+
0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,
// 0x30
+
0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,
// 0x40
+
0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,
// 0x50
+
0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,
// 0x60
+
0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,
// 0x70
+
0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,
// 0x80
+
0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,
// 0x90
+
0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,
// 0xa0
+
0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,
// 0xb0
+
0xf0,0xf1,0xf2,0xf3,0xf4,0xf5,0xf6,0xf7,0xf8,0xf9,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,
// 0xc0
+
0xf0,0xf1,0xf2,0xf3,0xf4,0xf5,0xf6,0xf7,0xf8,0xf9,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,
// 0xd0
+
0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,
// 0xe0
+
0xf0,0xf1,0xf2,0xf3,0xf4,0xf5,0xf6,0xf7,0xf8,0xf9,0xf0,0xf0,0xf0,0xf0,0xf0,0xf0,
// 0xf0
+ } ;
+
// We are going to make use of fact that a NumericDisplay's data is
// almost already in the format we need. We have to add a decimal point,
// if necessary, in the right place, and we need to tack on leading or
@@ -3097,50 +3232,67 @@ format_for_display_internal(char **dest,
}
}
- {//xxx
- // copy over the characters to the left of the decimal point:
- for(int i=0; i<ldigits; i++ )
- {
- char ch = *running_location++;
+ // copy over the characters to the left of the decimal point:
+ for(int i=0; i<ldigits; i++ )
+ {
+ unsigned char ch = *running_location++;
- // The default HIGH-VALUE of 0xFF runs afoul of the
- // NumericDisplay sign bit 0f 0x40 when running in
- // ASCII mode. The following test handles that problem
- // when HIGH-VALUE is still 0xFF. That HIGH-VALUE can
- // be changed by the SPECIAL-NAMES ALPHABET clause. But
+ // Welcome to COBOL. We might be dealing with a HIGH-VALUE, which
+ // is usually, but not always 0xFF. I am going to handle the 0xFF
+ // case. When the programmer messes with HIGH-VALUE in the
+ // SPECIAL-NAMES ALPHABET clause, then it becomes their problem.
- // I have decided that the onus of that problem is on
- // the user.
- if( (*dest)[index-1] != (char)DEGENERATE_HIGH_VALUE )
+ // But when it isn't HIGH-VALUE, we don't want to see the effects
+ // of the internal sign.
+ if( (*dest)[index-1] != (char)DEGENERATE_HIGH_VALUE )
+ {
+ // Another tricky thing, though, is that for various reasons
+ // the string of digits might not be digits. There can be
+ // REDEFINES, or the middle of the number might have been changed
+ // with an INITIALIZE into spaces. But we do want numbers to
+ // look like numbers. So, we do what we can:
+
+ if( internal_is_ebcdic )
{
- turn_sign_bit_off( PTRCAST(unsigned char, &ch));
+ ch = ebcdic_chars[ch];
+ }
+ else
+ {
+ ch = ascii_chars[ch];
}
- (*dest)[index++] = ch;
}
- if( rdigits )
- {
- // Lay down a decimal point
- (*dest)[index++] = ascii_to_internal(__gg__decimal_point);
+ (*dest)[index++] = ch;
+ }
+ if( rdigits )
+ {
+ // Lay down a decimal point
+ (*dest)[index++] = ascii_to_internal(__gg__decimal_point);
- if( ldigits < 0 )
+ if( ldigits < 0 )
+ {
+ // This is a scaled_e value, and we need that many zeroes:
+ for( int i=0; i<-ldigits; i++ )
{
- // This is a scaled_e value, and we need that many zeroes:
- for( int i=0; i<-ldigits; i++ )
- {
- (*dest)[index++] = internal_zero;
- }
+ (*dest)[index++] = internal_zero;
}
+ }
- // And the digits to the right
- for(int i=0; i<rdigits; i++ )
- {
- char ch = *running_location++;
+ // And the digits to the right
+ for(int i=0; i<rdigits; i++ )
+ {
+ unsigned char ch = *running_location++;
if( (*dest)[index-1] != (char)DEGENERATE_HIGH_VALUE )
{
- turn_sign_bit_off(PTRCAST(unsigned char, &ch));
+ if( internal_is_ebcdic )
+ {
+ ch = ebcdic_chars[ch];
+ }
+ else
+ {
+ ch = ascii_chars[ch];
}
- (*dest)[index++] = ch;
}
+ (*dest)[index++] = ch;
}
}
// At this point, for a 999PPP number, we need to tack on the zeroes
@@ -6715,7 +6867,7 @@ typedef struct normalized_operand
{
// These are the characters of the string. When the field is NumericDisplay
// any leading or trailing +/- characters are removed, and any embedded
- // NUMERIC_DISPLAY_SIGN_BIT bits are removed.
+ // minus bits are removed.
std::string the_characters;
size_t offset; // Usually zero. One when there is a leading sign.
size_t length; // Usually the same as the original. But it is one less
@@ -6778,7 +6930,7 @@ normalize_id( const cblc_field_t *refer,
for( size_t i=retval.offset; i<retval.length; i++ )
{
// Because we are dealing with a NumericDisplay that might have
- // the NUMERIC_DISPLAY_SIGN_BIT turned on, we need to mask it off
+ // the minus bit turned on, we need to mask it off
unsigned char ch = data[i];
turn_sign_bit_off(&ch);
retval.the_characters += ch;
@@ -7475,10 +7627,8 @@ __gg__inspect_format_1(int backward, size_t integers[])
// We are now set up to accomplish the data flow described
// in the language specification. We loop through the
// the character positions in normalized_id_1:
- const char *leftmost
- = normalized_id_1.the_characters.c_str();
- const char *rightmost
- = leftmost + normalized_id_1.length;
+ const char *leftmost = normalized_id_1.the_characters.c_str();
+ const char *rightmost = leftmost + normalized_id_1.length;
while( leftmost < rightmost )
{
@@ -7533,7 +7683,7 @@ __gg__inspect_format_1(int backward, size_t integers[])
break;
case bound_characters_e:
- match = 1;
+ match = true;
break;
case bound_all_e:
diff --git a/libgcobol/stringbin.cc b/libgcobol/stringbin.cc
index 2cc229e02002..34ddd8481179 100644
--- a/libgcobol/stringbin.cc
+++ b/libgcobol/stringbin.cc
@@ -331,7 +331,7 @@ __gg__binary_to_string_internal(char *result, int digits,
__int128 value)
static
void
-packed_from_combined(COMBINED &combined)
+packed_from_combined(const COMBINED &combined)
{
/* The combined.value must be positive at this point.
