From d9a44930e51fa6284c9ad92688ae171a52b43fe7 Mon Sep 17 00:00:00 2001
From: Bob Dubner <rdubner@symas.com>
Date: Mon, 17 Jun 2024 01:19:48 -0400
Subject: [PATCH] Refactor FldLiteralA to be completely static at run-time
---
.gitignore | 1 +
gcc/cobol/genapi.cc | 147 +++++++++++++++++++++++++++++++++++------
gcc/cobol/genutil.cc | 11 +--
libgcobol/libgcobol.cc | 4 +-
4 files changed, 134 insertions(+), 29 deletions(-)
diff --git a/.gitignore b/.gitignore
index 076713d5d148..8ec6320eac5d 100644
--- a/.gitignore
+++ b/.gitignore
@@ -76,5 +76,6 @@ stamp-*
# of having the BUILD directories adjacent to the SRC directory, rather than
# inside the SRC directory
build/
+buildrel/
build1/
build2/
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index 46b1c11b9ca5..c4dc29ea91dc 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -890,6 +890,11 @@ initialize_variable_internal( cbl_refer_t refer,
// gg_string_literal(refer.field->name),
// NULL_TREE);
cbl_field_t *parsed_var = refer.field;
+
+ if( parsed_var->type == FldLiteralA )
+ {
+ return;
+ }
if( parsed_var->is_key_name() )
{
@@ -1086,16 +1091,11 @@ initialize_variable_internal( cbl_refer_t refer,
{
// We have a clean refer with no mods, so we can send just the pointer to
// the field
- // FAZZBAZZ
- //gg_printf("KILROY ct %s %s\n", gg_string_literal(refer.field->name), gg_string_literal(cbl_field_type_str(refer.field->type)), NULL_TREE);
- //fprintf(stderr, "KILROY rt %s %s\n", refer.field->name, cbl_field_type_str(refer.field->type));
- //refer_fill_dest(refer);
gg_call(VOID,
"__gg__initialize_variable_clean",
2,
gg_get_address_of(refer.field->var_decl_node),
build_int_cst_type(INT, flag_bits) );
- //refer_release(refer);
}
suppress_dest_depends = true;
@@ -1862,8 +1862,6 @@ cobol_compare( tree return_int,
// now I decided to keep using the libgcobol code, which according to NIST
// works properly.
-// gg_printf(" KILROY %d\n", build_int_cst_type(INT, __LINE__), NULL_TREE);
-
if( !left_side_ref.refmod.from
&& !left_side_ref.refmod.len
&& !right_side_ref.refmod.from
@@ -1875,10 +1873,6 @@ cobol_compare( tree return_int,
int ntries = 1;
while( ntries <= 2 )
{
- // gg_printf(" KILROY %d %s %s\n", build_int_cst_type(INT, __LINE__),
- // gg_string_literal(cbl_field_type_str(lefty ->field->type)),
- // gg_string_literal(cbl_field_type_str(righty->field->type)),
- // NULL_TREE);
switch( lefty->field->type )
{
case FldLiteralN:
@@ -1976,7 +1970,6 @@ cobol_compare( tree return_int,
if( !compared )
{
-//gg_printf(" KILROY %d\n", build_int_cst_type(INT, __LINE__), NULL_TREE);
// None of our explicit comparisons up above worked, so we revert to the
// general case:
refer_fill_source(left_side_ref);
@@ -2070,7 +2063,6 @@ move_tree( cbl_refer_t &dest,
source_length,
gg_get_address_of(rdigits)));
-//gg_printf("KILROY %d\n", build_int_cst_type(INT, __LINE__), NULL_TREE);
gg_call(VOID,
"__gg__int128_to_refer",
5,
@@ -3984,6 +3976,7 @@ psa_FldBlob(struct cbl_field_t *var )
var->var_decl_node = gg_get_address_of(var_decl_node);
}
+
void
parser_accept( struct cbl_refer_t refer,
enum special_name_t special_e )
@@ -5163,6 +5156,7 @@ parser_move(cbl_refer_t destref,
bool skip_fill_from // Defaults to false
)
{
+
line_tick();
Analyze();
SHOW_PARSE
@@ -5235,12 +5229,18 @@ line_tick();
}
}
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_TEXT("About to call move_helper")
+ }
+
static bool dont_check_for_error = false;
move_helper(destref, sourceref, skip_fill_from, rounded, dont_check_for_error );
TRACE1
{
- TRACE1_HEADER
+ TRACE1_INDENT
TRACE1_REFER_INFO("source ", sourceref)
TRACE1_INDENT
TRACE1_REFER_INFO("dest ", destref)
@@ -11500,10 +11500,6 @@ create_and_call(size_t narg,
tree returned_value;
if( returned.field )
{
-//gg_printf("KILROY %d %s %p\n", build_int_cst_type(INT, __LINE__),
-// gg_string_literal(returned.field->name),
-// returned.refer_decl_node,
-// NULL_TREE);
returned_value = gg_define_variable(returned_value_type);
// We are expecting a return value of type CHAR_P, SSIZE_T, SIZE_T,
@@ -11572,10 +11568,6 @@ create_and_call(size_t narg,
// We got back a 64-bit or 128-bit integer. The called and calling
// programs have to agree on size, but other than that, integer numeric
// types are converted one to the other.
-// gg_printf("KILROY %d %s %p\n", build_int_cst_type(INT, __LINE__),
- // gg_string_literal(returned.field->name),
- // returned.refer_decl_node,
- // NULL_TREE);
gg_call(VOID,
"__gg__int128_to_refer",
5,
@@ -15322,6 +15314,110 @@ psa_new_var_decl(cbl_field_t *new_var, const char *external_record_base)
return new_var_decl;
}
+#if 1
+static void
+psa_FldLiteralA(struct cbl_field_t *field )
+ {
+ Analyze();
+ SHOW_PARSE
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" ", field)
+ SHOW_PARSE_END
+ }
+
+ TRACE1
+ {
+ TRACE1_HEADER
+ TRACE1_END
+ }
+
+ // We are constructing a completely static constant structure. We know the
+ // capacity. We'll create it from the data.initial. The cblc_field_t:data
+ // will be an ASCII/EBCDIC copy of the .initial data. The .initial will be
+ // left as ASCII. The var_decl_node will be an ordinary cblc_field_t, which
+ // means that at this point in time, a FldLiteralA can be used anywhere a
+ // FldGroup or FldAlphanumeric can be used. We are counting on the parser
+ // not allowing a FldLiteralA to be a left-hand-side variable.
+
+ // First make room
+ static size_t buffer_size = 1024;
+ static char *buffer = (char *)xmalloc(buffer_size);
+ if( buffer_size < field->data.capacity+1 )
+ {
+ buffer_size = field->data.capacity+1;
+ buffer = (char *)xrealloc(buffer, buffer_size);
+ }
+
+ cbl_figconst_t figconst = cbl_figconst_of( field->data.initial );
+ gcc_assert(figconst == normal_value_e);
+
+ if( internal_codeset_is_ebcdic() )
+ {
+ for( size_t i=0; i<field->data.capacity; i++ )
+ {
+ buffer[i] = ascii_to_internal(field->data.initial[i]);
+ }
+ }
+ else
+ {
+ memcpy(buffer, field->data.initial, field->data.capacity);
+ }
+ buffer[field->data.capacity] = '\0';
+
+ // We have the original nul-terminated text at data.initial. We have a
+ // copy of it in buffer[] in the internal codeset.
+
+ // We will re-use a single static structure for each string
+ static std::unordered_map<std::string, int> seen_before;
+ std::string field_string(buffer);
+ std::unordered_map<std::string, int>::const_iterator it =
+ seen_before.find(field_string);
+
+ static const char name_base[] = "_literal_a_";
+
+ if( it != seen_before.end() )
+ {
+ // We've seen that string before.
+ int nvar = it->second;
+ char ach[32];
+ sprintf(ach, "%s%d", name_base, nvar);
+ field->var_decl_node = gg_declare_variable(cblc_field_type_node,
+ ach,
+ NULL,
+ vs_file_static);
+ }
+ else
+ {
+ // We have not seen that string before
+ static int nvar = 1;
+ seen_before[field_string] = nvar;
+
+ char ach[32];
+ sprintf(ach, "%s%d", name_base, nvar);
+ field->var_decl_node = gg_define_variable( cblc_field_type_node,
+ ach,
+ vs_file_static);
+ actually_create_the_static_field(
+ field,
+ build_string_literal(field->data.capacity+1,
+ buffer),
+ field->data.capacity+1,
+ field->data.initial,
+ NULL_TREE,
+ field->var_decl_node);
+ nvar += 1;
+ }
+ TRACE1
+ {
+ TRACE1_INDENT
+ TRACE1_TEXT("Finished")
+ TRACE1_END
+ }
+ }
+#endif
+
+
void
parser_local_add(struct cbl_field_t *new_var )
{
@@ -15495,6 +15591,13 @@ parser_symbol_add(struct cbl_field_t *new_var )
return;
}
+ if( new_var->type == FldLiteralA )
+ {
+ new_var->data.picture = "";
+ psa_FldLiteralA(new_var);
+ return;
+ }
+
size_t length_of_initial_string = 0;
const char *new_initial = NULL;
diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc
index 6187fceb8794..db411e9b78e4 100644
--- a/gcc/cobol/genutil.cc
+++ b/gcc/cobol/genutil.cc
@@ -2449,7 +2449,7 @@ refer_fill_depends(cbl_refer_t &refer, refer_type_t refer_type)
}
}
-#define NEW_STYLE 1
+#define NEW_STYLE 0
void
refer_release(cbl_refer_t &refer)
@@ -2520,7 +2520,7 @@ refer_fill_internal(cbl_refer_t &refer, refer_type_t refer_type)
// This refer doesn't have a refer_decl_node, so we are reserving one
// for it.
- #if NEW_STYLE
+#if NEW_STYLE
tree referp_type = build_pointer_type(cblc_refer_type_node);
if( !refer.refer_decl_node )
{
@@ -2554,6 +2554,10 @@ refer_fill_internal(cbl_refer_t &refer, refer_type_t refer_type)
#if 1
if( refer.field && refer.field->type == FldLiteralA )
{
+ if(!refer.field->var_decl_node)
+ {
+ gcc_assert(refer.field->var_decl_node);
+ }
gg_assign(member(refer.refer_decl_node, "field"),
gg_cast(cblc_field_p_type_node,
gg_get_address_of(refer.field->var_decl_node)));
@@ -2566,9 +2570,6 @@ refer_fill_internal(cbl_refer_t &refer, refer_type_t refer_type)
gg_cast(UCHAR_P, gg_string_literal(litstring)));
gg_assign(member(refer.refer_decl_node, "qual_size"),
build_int_cst_type(SIZE_T, refer.field->data.capacity));
- gg_memcpy(member(refer.field, "data"),
- member(refer.refer_decl_node, "qual_data"),
- build_int_cst_type(SIZE_T, refer.field->data.capacity) );
}
else
#endif
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index b8a3a7e2442f..52cd3cd5ec3a 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -3647,8 +3647,8 @@ __gg__compare_2(cblc_field_t *left_side,
if( left_side->type == FldLiteralA )
{
- left_location = (unsigned char *)left_side->initial;
- left_length = strlen(left_side->initial);
+ left_location = (unsigned char *)left_side->data;
+ left_length = left_side->capacity;
}
static size_t right_string_size = MINIMUM_ALLOCATION_SIZE;
--
GitLab