git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

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.
This commit is contained in:
Robert Dubner 2025-08-11 20:56:38 -04:00
parent 1afd70fa2e
commit 9992c0a0e1
8 changed files with 531 additions and 466 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

468
gcc/cobol/genapi.cc
View File

@ -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.
// 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.
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
// 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 )
{
// The source is signable
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;
if( !(sourceref.field->attr & leading_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, 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( (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) )
// The source sign location is in the leading position.
if( source_is_separate )
{
// We have trailing separate
}
else
{
// 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));
}
ELSE
{
// The source was positive
gg_assign(gg_indirect(dest_p),
build_int_cst_type( UCHAR, EBCDIC_PLUS));
}
ENDIF
}
else
{
// The source is not signable, so the result is positive
// The source was negative
gg_assign(gg_indirect(dest_p),
build_int_cst_type( UCHAR, EBCDIC_PLUS));
build_int_cst_type( UCHAR, SEPARATE_MINUS));
}
ELSE
{
// The source was positive
gg_assign(gg_indirect(dest_p),
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() )
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 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
{
// 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;

1
gcc/cobol/genmath.cc
View File

@ -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 )
{

104
gcc/cobol/genutil.cc
View File

@ -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)
{

6
gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out
View File

@ -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

51
libgcobol/common-defs.h
View File

@ -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.
/* 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).
// 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
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)

1
libgcobol/configure vendored
View File

@ -16019,7 +16019,6 @@ fi
use_additional=yes
acl_save_prefix="$prefix"

364
libgcobol/libgcobol.cc
View File

@ -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;
}
else if( (resolved_var->attr & leading_e) )
{
sign_byte_location = resolved_location;
ch = *sign_byte_location;
turn_sign_bit_off(sign_byte_location);
}
else // if( !(resolved_var->attr & leading_e) )
{
sign_byte_location = resolved_location + resolved_length - 1;
ch = *sign_byte_location;
turn_sign_bit_off(sign_byte_location);
// 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);
}
}
// 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 );
// 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
{
for(size_t i=0; i<resolved_length; i++)
{
retval *= 10;
retval += from_ascii[resolved_location[i]];
}
}
*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++ )
// copy over the characters to the left of the decimal point:
for(int i=0; i<ldigits; i++ )
{
unsigned char ch = *running_location++;
// 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.
// 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 )
{
char ch = *running_location++;
// 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:
// 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
// I have decided that the onus of that problem is on
// the user.
if( (*dest)[index-1] != (char)DEGENERATE_HIGH_VALUE )
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 )
(*dest)[index++] = ch;
}
if( rdigits )
{
// Lay down a decimal point
(*dest)[index++] = ascii_to_internal(__gg__decimal_point);
if( ldigits < 0 )
{
// Lay down a decimal point
(*dest)[index++] = ascii_to_internal(__gg__decimal_point);
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:

2
libgcobol/stringbin.cc
View File

@ -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.