From 00956bcec7eb1fd86c9df23bc7da6d9c5e090062 Mon Sep 17 00:00:00 2001
From: Bob Dubner <rdubner@symas.com>
Date: Tue, 7 May 2024 17:06:55 -0400
Subject: [PATCH] wsclear(), with initialize_statement(to_default) hacked out
---
gcc/cobol/genapi.cc | 25 +++++++++++++++---
gcc/cobol/parse.y | 4 ++-
gcc/cobol/parse_ante.h | 1 -
gcc/cobol/symbols.h | 1 +
libgcobol/libgcobol.cc | 57 ++++++++++++++++++++++++++++++++++++------
5 files changed, 74 insertions(+), 14 deletions(-)
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index 0730546ba5c9..1e9b821981ae 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -1198,15 +1198,23 @@ initialize_variable_internal(cbl_refer_t refer, bool explicitly=false)
}
}
- // static int counter = 1;
- // fprintf(stderr, "counter %d %s\n", counter++, parsed_var->name);
+ static const int EXPLICIT_BIT = 0x200;
+ static const int DEFAULTBYTE_BIT = 0x100;
+ static const int DEFAULT_BYTE_MASK = 0x0FF;
+
+ int explicitbits = explicitly ? EXPLICIT_BIT : 0;
+ explicitbits |= wsclear()
+ ? DEFAULTBYTE_BIT + (*wsclear() & DEFAULT_BYTE_MASK)
+ : 0;
+
+ //fprintf(stderr, "CALLING WITH %s 0x%x\n", refer.field->name, explicitbits);
gg_call(VOID,
"__gg__initialize_variable",
4,
gg_get_address_of(refer.refer_decl_node),
is_redefined && !explicitly ? integer_one_node : integer_zero_node,
build_int_cst_type(UINT, refer.nsubscript),
- explicitly ? integer_one_node : integer_zero_node );
+ build_int_cst_type(INT, explicitbits) );
TRACE1
{
@@ -15553,7 +15561,16 @@ parser_symbol_add(struct cbl_field_t *new_var )
}
}
- new_initial = initial_from_float128(new_var, new_var->data.value);
+ if( wsclear() && !new_var->data.initial )
+ {
+ // We have a defaultbyte value, and an empty data.initial:
+ new_initial = (char *)xmalloc(new_var->data.capacity);
+ memset(const_cast<char *>(new_initial), *wsclear(), new_var->data.capacity);
+ }
+ else
+ {
+ new_initial = initial_from_float128(new_var, new_var->data.value);
+ }
if( new_initial )
{
switch(new_var->type)
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index 1716c7ce3d20..ae7ca7c6067d 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -10984,7 +10984,7 @@ struct expand_group : public std::list<cbl_refer_t> {
static const char * initial_default_value;
-static const char * wsclear() { return initial_default_value; }
+ const char * wsclear() { return initial_default_value; }
void
wsclear( char ch ) {
@@ -10999,6 +10999,8 @@ initialize_statement( cbl_refer_t tgt, bool with_filler,
const category_map_t& replacements,
bool to_default, bool explicitly = true )
{
+// DUBNER HACK
+to_default = false;
if( dimensions(tgt.field) < tgt.nsubscript ) {
yyerrorv( "syntax error: %s has %zu subscripts, but takes only %zu",
tgt.field->name, tgt.nsubscript, dimensions(tgt.field) );
diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h
index 6d0bd183829a..cf4e596a1e1f 100644
--- a/gcc/cobol/parse_ante.h
+++ b/gcc/cobol/parse_ante.h
@@ -2776,7 +2776,6 @@ data_division_ready() {
return true;
}
-static const char * wsclear();
static void apply_default_byte( cbl_field_t *field );
static bool
diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h
index ccd17d0eebf2..6c1fcc7c7907 100644
--- a/gcc/cobol/symbols.h
+++ b/gcc/cobol/symbols.h
@@ -2258,6 +2258,7 @@ static inline size_t upsi_register() {
}
void wsclear( char ch);
+const char *wsclear();
enum cbl_call_convention_t {
cbl_call_verbatim_e = 'V',
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index 1777d1bdea96..0dc151756b96 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -188,8 +188,6 @@ struct program_state
memset(rt_currency_signs, 0, sizeof(rt_currency_signs));
-
-
// The default collating sequence:
if( internal_is_ebcdic )
{
@@ -3984,8 +3982,17 @@ void
__gg__initialize_variable(cblc_refer_t *var_ref,
int is_redefined,
unsigned int nsubscripts,
- int explicitly)
+ int explicitbits)
{
+ // fprintf(stderr, "CALLED WITH %s 0x%x\n", var_ref->field->name, explicitbits);
+ static const int EXPLICIT_BIT = 0x200;
+ static const int DEFAULTBYTE_BIT = 0x100;
+ static const int DEFAULT_BYTE_MASK = 0x0FF;
+
+ bool explicitly = !!(explicitbits & EXPLICIT_BIT);
+ bool defaultbyte_in_play = !!(explicitbits & DEFAULTBYTE_BIT);
+ char defaultbyte = explicitbits & DEFAULT_BYTE_MASK;
+
// Make a copy of the field pointer we're working with as a convenience:
cblc_field_t *var = var_ref->field;
@@ -4218,7 +4225,6 @@ __gg__initialize_variable(cblc_refer_t *var_ref,
case FldGroup:
case FldAlphanumeric:
case FldAlphaEdited:
- case FldNumericDisplay:
case FldNumericEdited:
case FldLiteralA:
{
@@ -4230,9 +4236,44 @@ __gg__initialize_variable(cblc_refer_t *var_ref,
}
else if( !explicitly )
{
- memset( outer_location,
- internal_space,
- capacity );
+ if( !defaultbyte_in_play )
+ {
+ memset( outer_location,
+ internal_space,
+ capacity );
+ }
+ else
+ {
+ memset( outer_location,
+ defaultbyte,
+ capacity );
+ }
+ }
+ break;
+ }
+
+ case FldNumericDisplay:
+ {
+ // Any initialization values were converted to single-byte-coding in the
+ // right codeset during parser_symbol_add()
+ if( var->initial )
+ {
+ memcpy(outer_location, var->initial, var->capacity);
+ }
+ else if( !explicitly )
+ {
+ if( !defaultbyte_in_play )
+ {
+ memset( outer_location,
+ internal_space,
+ capacity );
+ }
+ else
+ {
+ memset( outer_location,
+ defaultbyte,
+ capacity );
+ }
}
break;
}
@@ -4311,7 +4352,7 @@ __gg__initialize_variable(cblc_refer_t *var_ref,
// See the comment up above about suppressing and restoring
// BLANK WHEN ZERO during initialization.
var->attr |= (save_the_attribute&blank_zero_e);
- }//initial
+ }
static void
alpha_to_alpha_move_from_location(cblc_refer_t *dest,
--
GitLab