From 3981b63883b879227e2ef59a05a184ae0ff619ca Mon Sep 17 00:00:00 2001
From: Bob Dubner <rdubner@symas.com>
Date: Sat, 13 Apr 2024 23:19:59 -0400
Subject: [PATCH] Transition to __gg__move_literala
---
gcc/cobol/genapi.cc | 41 +++++-
libgcobol/libgcobol.cc | 298 +++++++++++++++++++++++++++++++++++++++++
2 files changed, 335 insertions(+), 4 deletions(-)
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index 1a9e69000ff7..4238bf806b11 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -13468,10 +13468,6 @@ move_helper(cbl_refer_t destref,
tree size_error = gg_define_int(0);
- // gg_insert_into_assembler( "# DUBNER move_helper enter %s to %s",
- // sourceref.field->name,
- // destref.field->name );
-
static tree stash = gg_define_variable(UCHAR_P);
if( restore_on_error )
{
@@ -13546,6 +13542,43 @@ move_helper(cbl_refer_t destref,
//dont_be_clever:
+ if( !moved && sourceref.field->type == FldLiteralA)
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("__gg__move_literala")
+ }
+
+ refer_fill_dest(destref);
+
+ if( destref.refmod.from
+ || destref.refmod.len
+ || sourceref.refmod.from
+ || sourceref.refmod.len )
+ {
+ // Let the move routine know to treat the destination as alphanumeric
+ gg_attribute_bit_set(destref.field, refmod_e);
+ }
+
+ gg_assign(size_error,
+ gg_call_expr( INT,
+ "__gg__move_literala",
+ 3,
+ gg_get_address_of(destref.refer_decl_node),
+ gg_get_address_of(sourceref.refer_decl_node),
+ build_int_cst_type(INT, rounded)));
+ if( destref.refmod.from
+ || destref.refmod.len
+ || sourceref.refmod.from
+ || sourceref.refmod.len )
+ {
+ // Return that value to its original form
+ gg_attribute_bit_clear(destref.field, refmod_e);
+ }
+ moved = true;
+ }
+
if( !moved )
{
SHOW_PARSE
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index 161c150a3c64..d3e270f3029e 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -5142,6 +5142,304 @@ __gg__move( struct cblc_refer_t *dest,
return size_error;
}
+extern "C"
+int
+__gg__move_literala(struct cblc_refer_t *dest,
+ struct cblc_refer_t *source,
+ cbl_round_t rounded )
+ {
+ int size_error = 0; // This is the return value
+
+ bool moved = true;
+
+ __int128 value;
+ int rdigits;
+
+ cbl_figconst_t source_figconst =
+ (cbl_figconst_t)(source->field->attr & FIGCONST_MASK);
+ cbl_field_type_t dest_type = (cbl_field_type_t)dest->field->type;
+ cbl_field_type_t source_type = (cbl_field_type_t)source->field->type;
+
+ if( source_type != FldLiteralA )
+ {
+ fprintf(stderr, "KILROY How the fuck did this happen?\n");
+ abort();
+ }
+
+ if( var_is_refmod(dest->field) )
+ {
+ dest_type = FldAlphanumeric;
+ }
+
+ if( ( source_figconst == low_value_e
+ || source_figconst == space_value_e
+ || source_figconst == quote_value_e
+ || source_figconst == high_value_e )
+ &&
+ ( dest->field->type == FldNumericBinary
+ || dest->field->type == FldPacked
+ || dest->field->type == FldNumericBin5
+ || dest->field->type == FldNumericDisplay
+ || dest->field->type == FldFloat )
+ )
+ {
+ // Regardless of what you see below, as time went on it became clear that
+ // high-value and low-value required special processing in order to cope
+ // with code. Or, at least, to cope with legacy tests.
+
+ // The ISO 2014 specification has this to say about the moving of figurative
+ // constants to numerics:
+
+ // 14.9.24.3, paragraph 7)
+
+ /* NOTE: MOVE of the figurative constant QUOTE or QUOTES to a numeric data
+ * item is an obsolete feature and is to be removed from the next edition
+ * of standard COBOL. MOVE of figurative constants that are not numeric,
+ * other than QUOTE or QUOTES, to a numeric item is an archaic feature of
+ * standard COBOL and its use should be avoided
+ */
+
+ int special_char;
+ if( source_figconst == low_value_e )
+ {
+ special_char = ascii_to_internal(__gg__low_value_character);
+ }
+ else if( source_figconst == high_value_e )
+ {
+ special_char = ascii_to_internal(__gg__high_value_character);
+ }
+ else if( source_figconst == quote_value_e )
+ {
+ special_char = ascii_to_internal(__gg__quote_character);
+ }
+ else if( source_figconst == space_value_e )
+ {
+ special_char = ascii_to_internal(ascii_space);
+ }
+ memset(dest->qual_data, special_char, dest->qual_size);
+ }
+ else
+ {
+ switch( dest_type )
+ {
+ case FldGroup:
+ switch( source_type )
+ {
+ // For all other types, we just do a straight byte-for-byte move
+ case FldLiteralA:
+ alpha_to_alpha_move(dest, source, source->move_all);
+ break;
+
+ default:
+ abort();
+ moved = false;
+ break;
+ }
+
+ break;
+
+ case FldAlphanumeric:
+ {
+ switch( source_type )
+ {
+ case FldLiteralA:
+ alpha_to_alpha_move(dest, source, source->move_all);
+ break;
+
+
+ default:
+ moved = false;
+ break;
+ }
+ break;
+ }
+
+ case FldNumericBinary:
+ {
+ switch( source_type )
+ {
+ case FldLiteralA:
+ {
+ // We are moving a number to a number:
+ value = __gg__binary_value_from_refer(&rdigits, source);
+
+ if( truncation_mode == trunc_std_e )
+ {
+ if( value < 0 )
+ {
+ value = -value;
+ value %= __gg__power_of_ten(dest->field->digits);
+ value = -value;
+ }
+ else
+ {
+ value %= __gg__power_of_ten(dest->field->digits);
+ }
+ }
+
+ __gg__int128_to_refer(dest,
+ value,
+ rdigits,
+ rounded,
+ &size_error );
+ break;
+ }
+
+ default:
+ {
+ moved = false;
+ break;
+ }
+ }
+ break;
+ }
+
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldNumericBin5:
+ case FldPacked:
+ case FldIndex:
+ // Bin5 and Index are treated with no truncation, as if they were
+ // trunc_bin_e. The other types aren't subject to truncation.
+ switch( source_type )
+ {
+ case FldLiteralA:
+ {
+ // We are moving a number to a number:
+ value = __gg__binary_value_from_refer(&rdigits, source);
+ __gg__int128_to_refer( dest,
+ value,
+ rdigits,
+ rounded,
+ &size_error );
+ break;
+ }
+
+ default:
+ moved = false;
+ break;
+ }
+ break;
+
+ case FldAlphaEdited:
+ {
+ switch( source_type )
+ {
+ case FldLiteralA:
+ {
+ static size_t display_string_size = MINIMUM_ALLOCATION_SIZE;
+ static char *display_string = (char *)MALLOC(display_string_size);
+
+ size_t display_string_length = dest->qual_size;
+ __gg__realloc_if_necessary( &display_string,
+ &display_string_size,
+ display_string_length);
+
+ if( source_figconst == low_value_e )
+ {
+ memset(display_string, ascii_to_internal(__gg__low_value_character), dest->qual_size);
+ }
+ else if( source_figconst == zero_value_e )
+ {
+ memset(display_string, internal_zero, dest->qual_size);
+ }
+ else if( source_figconst == space_value_e )
+ {
+ memset(display_string, internal_space, dest->qual_size);
+ }
+ else if( source_figconst == quote_value_e )
+ {
+ memset(display_string, ascii_to_internal(__gg__quote_character), dest->qual_size);
+ }
+ else if( source_figconst == high_value_e )
+ {
+ memset(display_string, ascii_to_internal(__gg__high_value_character), dest->qual_size);
+ }
+ else
+ {
+ display_string = format_for_display_internal(
+ &display_string,
+ &display_string_size,
+ source->field,
+ (unsigned char *)source->qual_data,
+ source->qual_size,
+ source->address_of);
+ display_string_length = strlen(display_string);
+ }
+ __gg__string_to_alpha_edited( (char *)dest->qual_data,
+ display_string,
+ display_string_length,
+ dest->field->picture);
+ break;
+ }
+
+ default:
+ {
+ moved=false;
+ break;
+ }
+ }
+ break;
+ }
+
+ case FldFloat:
+ {
+ switch( source_type )
+ {
+ case FldLiteralA:
+ {
+ char ach[256];
+ size_t len = std::min(source->qual_size, sizeof(ach)-1);
+ memcpy(ach, source->qual_data, len);
+ ach[len] = '\0';
+ __gg__internal_to_console_in_place(ach, len);
+ switch( dest->field->capacity )
+ {
+ case 4:
+ {
+ *(float *)(dest->qual_data) = strtof32(ach, NULL);
+ break;
+ }
+ case 8:
+ {
+ *(double *)(dest->qual_data) = strtof64(ach, NULL);
+ break;
+ }
+ case 16:
+ {
+ *(_Float128 *)(dest->qual_data) = strtof128(ach, NULL);
+ break;
+ }
+ break;
+ }
+ break;
+ }
+
+ default:
+ {
+ moved = false;
+ break;
+ }
+ }
+ break;
+ }
+
+ default:
+ moved = false;
+ break;
+ }
+ if( !moved )
+ {
+ fprintf(stderr, "%s() %s:%d -- We were unable to do a move from "
+ "type %d to %d\n",
+ __func__, __FILE__, __LINE__,
+ source->field->type, dest->field->type);
+ exit(1);
+ }
+ }
+ return size_error;
+ }
+
extern "C"
void
__gg__file_sort_ff_input( cblc_file_t *workfile,
--
GitLab