From b5ff89770d31ed6b22bf897a08ed3ef706d7357f Mon Sep 17 00:00:00 2001
From: Bob Dubner <rdubner@symas.com>
Date: Sat, 20 Apr 2024 17:21:39 -0400
Subject: [PATCH] Added very_true_register() and very_false_register(); tested
true_op and false_op
---
gcc/cobol/failures/.gitignore | 1 +
gcc/cobol/genapi.cc | 150 ++++++++++++++++++++++++++++------
gcc/cobol/genutil.cc | 5 ++
gcc/cobol/symbols.cc | 13 ++-
gcc/cobol/symbols.h | 2 +
libgcobol/libgcobol.cc | 22 ++---
6 files changed, 155 insertions(+), 38 deletions(-)
diff --git a/gcc/cobol/failures/.gitignore b/gcc/cobol/failures/.gitignore
index b58c7495295e..d2b80300e0aa 100644
--- a/gcc/cobol/failures/.gitignore
+++ b/gcc/cobol/failures/.gitignore
@@ -10,3 +10,4 @@ dump.txt
*.html
XXXXX*
REPORTT
+simon/
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index b372e9c635cd..656cfc3c3a20 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -563,12 +563,12 @@ get_class_condition_string(cbl_field_t *var)
{
// Since the first.name is a single character, we can do this as
// a single-character pair.
-
+
// Keep in mind that the single character might be a two-byte UTF-8
// codepoint
uint8_t ch1 = domain->first.name[0];
uint8_t ch2 = domain->last.name[0];
-
+
gcc_assert(strlen(domain->first.name) <= 2);
gcc_assert(strlen(domain->last.name) <= 2);
@@ -1984,7 +1984,7 @@ cobol_compare( tree return_int,
// It is the case that data.initial is in the original form seen
// in the source code, which means that even in EBCDIC mode the
// characters are in the "raw" state.
-
+
static size_t buffer_size = 0;
static char *buffer = NULL;
raw_to_internal(&buffer,
@@ -2785,7 +2785,7 @@ parser_goto( cbl_refer_t value_ref, size_t narg, cbl_label_t *labels[] )
// the other two, because it just has to jump from here to the entry point
// of the paragraph [or section]
Analyze();
-
+
SHOW_PARSE
{
SHOW_PARSE_HEADER
@@ -4003,7 +4003,7 @@ parser_accept_envar( struct cbl_refer_t refer, struct cbl_refer_t envar )
tree env_length;
refer_fill_dest(refer);
-
+
if( envar.field->type == FldLiteralA )
{
char *buffer = get_literal_string(envar.field);
@@ -4812,7 +4812,7 @@ parser_assign( size_t nC, cbl_num_result_t *C,
IF( gg_bitwise_and( compute_error->structs.compute_error->compute_error_code,
build_int_cst_type(INT,
- compute_error_exp_minus_by_frac
+ compute_error_exp_minus_by_frac
| compute_error_divide_by_zero)),
ne_op,
integer_zero_node )
@@ -5250,7 +5250,7 @@ parser_exit(void)
// The byte array to be returned is in returning, which is a local
// variable on the stack. We need to make a copy of it to avoid the
// error of returning a pointer to data on the stack.
-
+
tree array_type = build_array_type_nelts(UCHAR,
current_function->returning->data.capacity);
tree retval = gg_define_variable(array_type, vs_static);
@@ -5642,7 +5642,7 @@ parser_division(cbl_division_t division,
IF( globals_are_initialized, eq_op, integer_zero_node )
{
// one-time initialization happens here
-
+
// We need to establish the initial value of the UPSI-1 switch register
// We are using IBM's conventions:
// https://www.ibm.com/docs/en/zvse/6.2?topic=SSB27H_6.2.0/fa2sf_communicate_appl_progs_via_job_control.html
@@ -5962,6 +5962,12 @@ parser_logop( struct cbl_field_t *tgt,
SHOW_PARSE_FIELD(" ", tgt)
SHOW_PARSE_TEXT(" will be set to TRUE ")
}
+ else if( logop == false_op)
+ {
+ SHOW_PARSE_HEADER
+ SHOW_PARSE_FIELD(" ", tgt)
+ SHOW_PARSE_TEXT(" will be set to FALSE ")
+ }
else
{
SHOW_PARSE_HEADER
@@ -5973,13 +5979,27 @@ parser_logop( struct cbl_field_t *tgt,
}
SHOW_PARSE_TEXT(" ")
SHOW_PARSE_TEXT( cbl_logop_str(logop) )
- SHOW_PARSE_FIELD(" ", b)
+ if( b )
+ {
+ SHOW_PARSE_FIELD(" ", b)
+ }
}
SHOW_PARSE_END
}
CHECK_FIELD(tgt);
- CHECK_FIELD(b);
+ switch(logop)
+ {
+ case and_op:
+ case or_op:
+ case xor_op:
+ case xnor_op:
+ case not_op:
+ CHECK_FIELD(b);
+ break;
+ default:
+ break;
+ }
TRACE1
{
@@ -5994,15 +6014,24 @@ parser_logop( struct cbl_field_t *tgt,
TRACE1_FIELD("operand A: ", a, "");
}
TRACE1_INDENT
- TRACE1_FIELD("operand B: ", b, "");
+ if( b )
+ {
+ TRACE1_FIELD("operand B: ", b, "");
+ }
TRACE1_END
}
}
- // Make sure the variables are okay:
- if( a )
+ switch(logop)
{
- CHECK_FIELD(a);
+ case and_op:
+ case or_op:
+ case xor_op:
+ case xnor_op:
+ CHECK_FIELD(a);
+ break;
+ default:
+ break;
}
// This routine takes two conditionals and a logical operator. From those,
@@ -6022,7 +6051,7 @@ parser_logop( struct cbl_field_t *tgt,
a->name, cobol_location().first_line);
gcc_assert(false);
}
- if( b->type != FldConditional )
+ if( b && b->type != FldConditional )
{
warnx("parser_logop() was called with variable %s on line %d"
", which is not a FldConditional\n",
@@ -8828,7 +8857,7 @@ parser_inspect_replacing( cbl_refer_t identifier_1,
{
if( pcbl_refers[i].field && pcbl_refers[i].field->type == FldLiteralN )
{
- fprintf(stderr, "INSPECT field %s shouldn't be a FldLiteralN\n",
+ fprintf(stderr, "INSPECT field %s shouldn't be a FldLiteralN\n",
pcbl_refers[i].field->name);
gcc_assert(false);
}
@@ -11076,7 +11105,7 @@ parser_call( cbl_refer_t name,
switch( crv )
{
- case by_default_e:
+ case by_default_e:
assert(false);
break;
@@ -11241,7 +11270,7 @@ parser_call( cbl_refer_t name,
build_int_cst_type(INT, narg));
refer_fill_source(name);
- tree unmangled_name = gg_define_char_star();
+ tree unmangled_name = gg_define_char_star();
gg_assign(unmangled_name, gg_call_expr( CHAR_P,
"__gg__name_not_mangled",
1,
@@ -12432,13 +12461,70 @@ parser_file_stash( struct cbl_file_t *file )
static void
hijack_for_development(const char *funcname)
{
+ /*
+
+ To make sure that things like global symbols and whatnot get initialized, you
+ should probably create a source file that looks like this:
+
+ identification division.
+ program-id. prog.
+ procedure division.
+ call "dubner".
+ end program prog.
+ identification division.
+ program-id. dubner.
+ procedure division.
+ goback.
+ end program dubner.
+
+ The first program will cause all of the parser_enter_program() and
+ parser_division(procedure_div_e) stuff to be initialized. The second program,
+ named "dubner", will be hijacked and bring you here. */
+
// Assume that funcname is lowercase with no hyphens
enter_program_common(funcname, funcname);
+ parser_display_literal("You have been hijacked by a program named \"dubner\"");
// It is at this point we can forcibly lay down code
gg_insert_into_assembler("# HIJACKED DUBNER CODE START");
+#if 1
+ cbl_field_t cond = {};
+ cond.type = FldConditional;
+ strcpy(cond.name, "_hijacked");
+ cond.var_decl_node = gg_define_variable(BOOL);
+
+ parser_logop(&cond, NULL, true_op, NULL);
+ parser_if(&cond);
+ parser_display_literal("It is TRUE");
+ parser_else();
+ parser_display_literal("It is FALSE");
+ parser_fi();
+
+ parser_logop(&cond, NULL, false_op, NULL);
+ parser_if(&cond);
+ parser_display_literal("It is TRUE");
+ parser_else();
+ parser_display_literal("It is FALSE");
+ parser_fi();
+
+ cbl_field_t *very_true = cbl_field_of(symbol_at(very_true_register()));
+ cbl_field_t *very_false = cbl_field_of(symbol_at(very_false_register()));
+
+ parser_if(very_true);
+ parser_display_literal("It is TRUE");
+ parser_else();
+ parser_display_literal("It is FALSE");
+ parser_fi();
+
+ parser_if(very_false);
+ parser_display_literal("It is TRUE");
+ parser_else();
+ parser_display_literal("It is FALSE");
+ parser_fi();
+
gg_insert_into_assembler("# HIJACKED DUBNER CODE END");
+#endif
}
static void
@@ -13812,7 +13898,7 @@ move_helper(cbl_refer_t destref,
}
}
- int rounded_parameter = rounded
+ int rounded_parameter = rounded
| ((sourceref.all || figconst ) ? REFER_ALL_BIT : 0);
gg_assign(size_error,
@@ -14462,7 +14548,7 @@ actually_create_the_static_field( cbl_field_t *new_var,
// SIZE_T, "capacity",
CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
next_field,
- build_int_cst_type( SIZE_T,
+ build_int_cst_type( SIZE_T,
new_var->data.capacity) );
next_field = TREE_CHAIN(next_field);
@@ -14471,14 +14557,14 @@ actually_create_the_static_field( cbl_field_t *new_var,
{
CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
next_field,
- build_int_cst_type( SIZE_T,
+ build_int_cst_type( SIZE_T,
new_var->data.capacity) );
}
else
{
CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(constr),
next_field,
- build_int_cst_type( SIZE_T,
+ build_int_cst_type( SIZE_T,
0) );
}
@@ -14637,6 +14723,17 @@ psa_global(cbl_field_t *new_var)
fprintf(stderr, " };\n");
}
+ if( strcmp(new_var->name, "_VERY_TRUE") == 0 )
+ {
+ new_var->var_decl_node = boolean_true_node;
+ return;
+ }
+ if( strcmp(new_var->name, "_VERY_FALSE") == 0 )
+ {
+ new_var->var_decl_node = boolean_false_node;
+ return;
+ }
+
// global variables already have a cblc_field_t defined in constants.cc
strcpy(ach, "__gg__");
@@ -14770,7 +14867,7 @@ psa_new_var_decl(cbl_field_t *new_var, const char *external_record_base)
new_var->name,
inter_count++);
}
- else if( new_var->attr & temporary_e
+ else if( new_var->attr & temporary_e
&& !is_literal(new_var) )
{
static int temp_count = 1;
@@ -14794,7 +14891,7 @@ psa_new_var_decl(cbl_field_t *new_var, const char *external_record_base)
base_name,
vs_external);
}
- else if( new_var->attr & (temporary_e | intermediate_e)
+ else if( new_var->attr & (temporary_e | intermediate_e)
&& new_var->type != FldLiteralA
&& new_var->type != FldLiteralN )
{
@@ -14950,10 +15047,11 @@ parser_symbol_add(struct cbl_field_t *new_var )
{
gg_assign(new_var->var_decl_node, boolean_false_node);
}
-
+
return;
}
+
if( !(new_var->attr & initialized_e) )
{
cbl_field_type_t incoming_type = new_var->type;
@@ -15367,7 +15465,7 @@ parser_symbol_add(struct cbl_field_t *new_var )
if( bytes_to_allocate )
{
- if( new_var->attr & (temporary_e | intermediate_e)
+ if( new_var->attr & (temporary_e | intermediate_e)
&& new_var->type != FldLiteralN
&& new_var->type != FldLiteralA )
{
diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc
index 38b3ef5be05c..c0be6cfba5ad 100644
--- a/gcc/cobol/genutil.cc
+++ b/gcc/cobol/genutil.cc
@@ -2479,6 +2479,11 @@ refer_fill_internal(cbl_refer_t &refer, refer_type_t refer_type)
// This routine establishes the qualifed .qual_data and .qual_size values
// from the original .data and .capacity values
+ if( refer.field->type == FldConditional )
+ {
+ gcc_assert(false);
+ }
+
gg_assign(member(refer.refer_decl_node, "qual_data"),
member(refer.field->var_decl_node, "data"));
if( refer.field->attr & (intermediate_e | any_length_e) )
diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc
index d02a01c3dc11..9e4af26aa7b1 100644
--- a/gcc/cobol/symbols.cc
+++ b/gcc/cobol/symbols.cc
@@ -72,7 +72,8 @@ static struct symbol_table_t {
size_t capacity, nelem;
size_t first_program, procedures;
struct {
- size_t file_status, linage_counter, return_code, exception_condition;
+ size_t file_status, linage_counter, return_code,
+ exception_condition, very_true, very_false;
} registers;
struct symbol_elem_t *elems;
@@ -179,6 +180,8 @@ static char decimal_point = '.';
size_t file_status_register() { return symbols.registers.file_status; }
size_t return_code_register() { return symbols.registers.return_code; }
+size_t very_true_register() { return symbols.registers.very_true; }
+size_t very_false_register() { return symbols.registers.very_false; }
size_t ec_register() { return symbols.registers.exception_condition; }
cbl_refer_t *
@@ -2114,6 +2117,12 @@ symbol_table_init(void) {
"QUOTES", 0, {1,1,0,0, "\"\0\xFF", NULL, { NULL }, { NULL } }, NULL },
{ 0, FldPointer, FldPointer, constq , 0, 0, 0, nonarray, 0,
"NULLS", 0, {8,8,0,0, zeroes_for_null_pointer, NULL, { NULL }, { NULL } }, NULL },
+ // These last two don't require actual storage; they get BOOL var_decl_node
+ // in parser_symbol_add()
+ { 0, FldConditional, FldInvalid, constant_e , 0, 0, 0, nonarray, 0,
+ "_VERY_TRUE", 0, {1,1,0,0, "", NULL, { NULL }, { NULL } }, NULL },
+ { 0, FldConditional, FldInvalid, constant_e , 0, 0, 0, nonarray, 0,
+ "_VERY_FALSE", 0, {1,1,0,0, "", NULL, { NULL }, { NULL } }, NULL },
};
for( struct cbl_field_t *f = constants;
f < constants + COUNT_OF(constants); f++ ) {
@@ -2198,6 +2207,8 @@ symbol_table_init(void) {
"LINAGE-COUNTER"));
symbols.registers.file_status = symbol_index(symbol_field(0,0, "_FILE_STATUS"));
symbols.registers.return_code = symbol_index(symbol_field(0,0, "RETURN-CODE"));
+ symbols.registers.very_true = symbol_index(symbol_field(0,0, "_VERY_TRUE"));
+ symbols.registers.very_false = symbol_index(symbol_field(0,0, "_VERY_FALSE"));
if( getenv(__func__) ) symbols_dump(0, true);
}
diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h
index c4acbfae0e63..aff38a8eaa3e 100644
--- a/gcc/cobol/symbols.h
+++ b/gcc/cobol/symbols.h
@@ -2186,6 +2186,8 @@ size_t symbol_field_capacity( const cbl_field_t *field );
size_t file_status_register();
size_t return_code_register();
+size_t very_true_register();
+size_t very_false_register();
size_t ec_register();
static inline size_t upsi_register() {
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index 2d49468f287c..1777d1bdea96 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -2757,7 +2757,7 @@ format_for_display_internal(char **dest,
memset(buffer, internal_0, new_length);
char *p = buffer;
char *s = *dest;
- if( ((*dest)[0]&0xFF) < internal_0
+ if( ((*dest)[0]&0xFF) < internal_0
|| ((*dest)[0]&0xFF) > internal_9 )
{
*p++ = (*dest)[0];
@@ -3989,8 +3989,8 @@ __gg__initialize_variable(cblc_refer_t *var_ref,
// Make a copy of the field pointer we're working with as a convenience:
cblc_field_t *var = var_ref->field;
- if( var_ref->field->data == NULL
- && var_ref->field->attr & (temporary_e | intermediate_e)
+ if( var_ref->field->data == NULL
+ && var_ref->field->attr & (temporary_e | intermediate_e)
&& var_ref->field->type != FldLiteralA
&& var_ref->field->type != FldLiteralN )
{
@@ -4311,7 +4311,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,
@@ -5178,7 +5178,7 @@ __gg__move_literala(struct cblc_refer_t *dest,
case FldGroup:
case FldAlphanumeric:
{
- alpha_to_alpha_move_from_location(dest, str, strlen, move_all);
+ alpha_to_alpha_move_from_location(dest, str, strlen, move_all);
break;
}
@@ -5283,7 +5283,7 @@ __gg__move_literala(struct cblc_refer_t *dest,
if( !moved )
{
- fprintf(stderr, "%s() %s:%d -- We were unable to do a move to "
+ fprintf(stderr, "%s() %s:%d -- We were unable to do a move to "
"type %d\n",
__func__, __FILE__, __LINE__,
dest->field->type);
@@ -7719,7 +7719,7 @@ is_numeric_display_numeric(cblc_refer_t *str)
// all remaining characters are supposed to be zero through nine
while( digits < digits_e )
{
- if( (unsigned char)(*digits)<internal_0
+ if( (unsigned char)(*digits)<internal_0
|| (unsigned char)(*digits)>internal_9 )
{
retval = 0;
@@ -7811,7 +7811,7 @@ is_alpha_a_number(cblc_refer_t *str)
int retval = 1;
for( size_t i=0; i<str->qual_size; i++ )
{
- if( (unsigned char)str->qual_data[i] < internal_0
+ if( (unsigned char)str->qual_data[i] < internal_0
|| (unsigned char)str->qual_data[i] > internal_9 )
{
retval = 0;
@@ -7889,7 +7889,7 @@ __gg__classify( classify_t type, cblc_refer_t *str)
}
// If necessary, this could be sped up with the creation of
// appropriate mapping tables.
-
+
// The oddball construction of this if() statement is a consequence of
// EBCDIC. Because of peculiarities going all the back to the encoding
// of characters on IBM cards, where it wasn't a good idea to have too
@@ -9670,7 +9670,7 @@ __gg__parameter_count_push( char *called_function,
// __gg__parameter_count_pop
called_functions.push_back(called_function);
parameter_counts.push_back(parameter_count);
-
+
int *plengths = (int *)malloc(parameter_count);
memcpy(plengths, parameter_lengths, parameter_count * sizeof(int));
parameter_lengthss.push_back(plengths);
@@ -9766,7 +9766,7 @@ find_in_dirs(const char *dirs, char *unmangled_name, char *mangled_name)
break;
}
size_t len = strlen(entry->d_name);
- if( len > 3
+ if( len > 3
&& entry->d_name[len-3] == '.'
&& entry->d_name[len-2] == 's'
&& entry->d_name[len-1] == 'o'
--
GitLab