diff --git a/gcc/cobol/etests/.gitignore b/gcc/cobol/etests/.gitignore
index 305b2f7b405f7dc8e076d070bacf356de4484a70..eaf70718543139a05c603bf6fcd8169d03e82188 100644
--- a/gcc/cobol/etests/.gitignore
+++ b/gcc/cobol/etests/.gitignore
@@ -3,3 +3,6 @@ under-test.txt
*.s
*.rpt
*.o
+*.json
+*.html
+*.nodes
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index d25008bf823837b60283e791e9dc1bf4c4a0ba26..4e4ab7a7b3ba668438d49cf842cb7d65560214c5 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -4344,6 +4344,34 @@ parser_display_internal(tree file_descriptor,
ENDIF
}
}
+ else if( refer.field->type == FldLiteralA )
+ {
+ char *buffer = NULL;
+ size_t buffer_size = 0;
+
+ // Maximum size is twice capacity (for all UTF-8 characters) plus one byte
+ // for the terminating NUL character
+ size_t max_possible = 2*refer.field->data.capacity + 1;
+
+ if( max_possible > buffer_size )
+ {
+ buffer_size = max_possible;
+ buffer = (char *)xrealloc(buffer, max_possible);
+ }
+ __gg__ascii_to_console(&buffer,
+ &buffer_size,
+ refer.field->data.initial,
+ refer.field->data.capacity );
+ gg_write( file_descriptor,
+ gg_string_literal(buffer),
+ build_int_cst_type(SIZE_T, strlen(buffer)));
+ if( advance )
+ {
+ gg_write( file_descriptor,
+ gg_string_literal("\n"),
+ integer_one_node);
+ }
+ }
else if( refer.field->type == FldLiteralN )
{
// The parser found the string of digits from the source code and converted
@@ -13440,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 )
{
@@ -13516,7 +13540,98 @@ move_helper(cbl_refer_t destref,
size_error);
}
- //dont_be_clever:
+ if( !moved && sourceref.field->type == FldLiteralA)
+ {
+ SHOW_PARSE
+ {
+ SHOW_PARSE_INDENT
+ SHOW_PARSE_TEXT("__gg__move_literala")
+ }
+
+ refer_fill_dest(destref);
+
+ cbl_figconst_t figconst = cbl_figconst_of( sourceref.field->data.initial);
+
+ if( destref.refmod.from
+ || destref.refmod.len )
+ {
+ // Let the move routine know to treat the destination as alphanumeric
+ gg_attribute_bit_set(destref.field, refmod_e);
+ }
+
+ static char *buffer = NULL;
+ static size_t buffer_size = 0;
+ size_t source_length = sourceref.field->data.capacity;
+
+ if( buffer_size < source_length )
+ {
+ buffer_size = source_length;
+ buffer = (char *)xrealloc(buffer, buffer_size);
+ }
+
+ if( figconst )
+ {
+ char const_char = 0xFF; // Head off a compiler warning about
+ // // uninitialized variables
+ switch(figconst)
+ {
+ case normal_value_e :
+ // This is not possible, it says here in the fine print.
+ abort();
+ break;
+ case low_value_e :
+ const_char = ascii_to_internal(__gg__low_value_character);
+ break;
+ case zero_value_e :
+ const_char = internal_zero;
+ break;
+ case space_value_e :
+ const_char = internal_space;
+ break;
+ case quote_value_e :
+ const_char = ascii_to_internal(__gg__quote_character);
+ break;
+ case high_value_e :
+ const_char = ascii_to_internal(__gg__high_value_character);
+ break;
+ case null_value_e:
+ const_char = 0x00;
+ break;
+ }
+ memset(buffer, const_char, source_length);
+ }
+ else
+ {
+ memset( buffer, ascii_space, source_length);
+ memcpy( buffer,
+ sourceref.field->data.initial,
+ std::min(source_length, (size_t)sourceref.field->data.capacity) );
+ for( size_t i=0; i<source_length; i++)
+ {
+ buffer[i] = ascii_to_internal(buffer[i]);
+ }
+ }
+
+ int rounded_parameter = rounded
+ | ((sourceref.all || figconst ) ? REFER_ALL_BIT : 0);
+
+ gg_assign(size_error,
+ gg_call_expr( INT,
+ "__gg__move_literala",
+ 4,
+ gg_get_address_of(destref.refer_decl_node),
+ build_int_cst_type(INT, rounded_parameter),
+ build_string_literal(source_length,
+ buffer),
+ build_int_cst_type( SIZE_T, source_length)));
+ if( destref.refmod.from
+ || destref.refmod.len )
+ {
+ // Return that value to its original form
+ gg_attribute_bit_clear(destref.field, refmod_e);
+ }
+ moved = true;
+ }
if( !moved )
{
diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h
index 4bd2ac92b74ac072d661f0d3a2e512e49be6634d..f2a71639185284ea1c9247b750c66f4248c5661e 100644
--- a/gcc/cobol/symbols.h
+++ b/gcc/cobol/symbols.h
@@ -114,6 +114,10 @@ static inline bool gcobol_feature_embiggen() {
(cbl_gcobol_features & feature_embiggen_e);
}
+// In the __gg__move_literala() call, we piggyback this bit onto the
+// cbl_round_t parameter, just to cut down on the number of parameters passed
+#define REFER_ALL_BIT 0x80
+
enum cbl_round_t {
away_from_zero_e,
nearest_toward_zero_e,
diff --git a/gcc/cobol/tests/MakeVars.inc b/gcc/cobol/tests/MakeVars.inc
index e4e80915936fbf9565357ed6a86a9b1f9c4f2d51..5215a85ba4586c7ad7b0c833f4f1334cb8f1381c 100644
--- a/gcc/cobol/tests/MakeVars.inc
+++ b/gcc/cobol/tests/MakeVars.inc
@@ -51,7 +51,7 @@ LIBSTDC_PATH = $(LIBROOT)/libstdc++-v3/src/.libs
comma = ,
RPATH = $(addprefix -Wl$(comma)-rpath=,$(LIBCOBOL_PATH) $(LIBSTDC_PATH))
-COBOL_RUNTIME_LIBRARY = $(LIBCOBOL_A) $(RPATH)
+COBOL_RUNTIME_LIBRARY = $(RPATH)
SEARCH_PATHS = \
-B $(GCC_BIN) \
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index 161c150a3c64ed4379d94db809e0c281bf276aff..e34785f9a31610420b846a7fc1db327368ae8b5a 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -4572,7 +4572,6 @@ __gg__move( struct cblc_refer_t *dest,
{
// For all other types, we just do a straight byte-for-byte move
case FldAlphanumeric:
- case FldLiteralA:
case FldNumericEdited:
case FldAlphaEdited:
case FldNumericDisplay:
@@ -4602,7 +4601,6 @@ __gg__move( struct cblc_refer_t *dest,
break;
case FldAlphanumeric:
- case FldLiteralA:
case FldNumericEdited:
case FldAlphaEdited:
// This is an ordinary alpha-to-alpha move:
@@ -4931,7 +4929,6 @@ __gg__move( struct cblc_refer_t *dest,
}
break;
- case FldLiteralA:
case FldAlphanumeric:
case FldNumericDisplay:
case FldNumericEdited:
@@ -5090,7 +5087,6 @@ __gg__move( struct cblc_refer_t *dest,
{
switch( source_type )
{
- case FldLiteralA:
case FldAlphanumeric:
{
char ach[256];
@@ -5142,6 +5138,149 @@ __gg__move( struct cblc_refer_t *dest,
return size_error;
}
+extern "C"
+int
+__gg__move_literala(struct cblc_refer_t *dest,
+ cbl_round_t rounded_,
+ const char *str,
+ size_t strlen )
+ {
+ cbl_round_t rounded = static_cast<cbl_round_t>(rounded_ & ~REFER_ALL_BIT);
+ bool move_all = !!(rounded_ & REFER_ALL_BIT);
+
+ int size_error = 0; // This is the return value
+
+ bool moved = true;
+
+ __int128 value;
+ int rdigits;
+
+ cbl_field_type_t dest_type = (cbl_field_type_t)dest->field->type;
+ if( var_is_refmod(dest->field) )
+ {
+ dest_type = FldAlphanumeric;
+ }
+
+ switch( dest_type )
+ {
+ case FldGroup:
+ case FldAlphanumeric:
+ {
+ alpha_to_alpha_move_from_location(dest, str, strlen, move_all);
+ break;
+ }
+
+ case FldNumericBinary:
+ {
+ value = __gg__dirty_to_binary_internal( str,
+ strlen,
+ &rdigits );
+ 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;
+ }
+
+ 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.
+ // We are moving a number to a number:
+ value = __gg__dirty_to_binary_internal( str,
+ strlen,
+ &rdigits );
+ __gg__int128_to_refer(dest,
+ value,
+ rdigits,
+ rounded,
+ &size_error );
+ break;
+
+ case FldAlphaEdited:
+ {
+ 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);
+
+ memset(display_string, internal_space, display_string_size);
+ size_t len = std::min(display_string_size, strlen);
+ memcpy(display_string, str, len);
+
+ __gg__string_to_alpha_edited( (char *)dest->qual_data,
+ display_string,
+ display_string_length,
+ dest->field->picture);
+ break;
+ }
+
+ case FldFloat:
+ {
+ char ach[256];
+ size_t len = std::min(strlen, sizeof(ach)-1);
+ memcpy(ach, str, len);
+ ach[len] = '\0';
+ 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;
+ }
+
+ if( !moved )
+ {
+ fprintf(stderr, "%s() %s:%d -- We were unable to do a move to "
+ "type %d\n",
+ __func__, __FILE__, __LINE__,
+ dest->field->type);
+ exit(1);
+ }
+
+ return size_error;
+ }
+
extern "C"
void
__gg__file_sort_ff_input( cblc_file_t *workfile,