git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

cobol: Implement ENTRY statement; finish removing ascii/ebcdic dichotomy. 

The prior set of changes largely eliminated the assumption that the
internal codeset was either ascii or ebcdic.  These changes remove the
last vestiges of that assumption.

These changes also implement the COBOL ENTRY statement, which allows a
program-id to have more than one externally callable entry point. Since
GCC assumes the existence of an ABI that is not, repeat *not* capable of
that, it is implemented here by creating a separate function with the
name specified by the ENTRY statement.  That function sets up global
variables which cause control to be transferred to the ENTRY point when
the parent function is called re-entrantly, and then executes that call.

gcc/cobol/ChangeLog:

	* genapi.cc (move_tree): Formatting.
	(parser_enter_file): Incorporate global __gg__entry_label.
	(enter_program_common): Remove calls to alphabet overrides.
	(parser_alphabet): Change cbl_alphabet_e handling.
	(parser_alphabet_use): Likewise.
	(initialize_the_data): Likewise.
	(establish_using): Process passed parameters in a subroutine.
	(parser_division): Remove in-line parameter processing;
	call establish_using() instead. Check for __gg__entry_label.
	(parser_file_add): Temporary workaround for charset encoding.
	(parser_file_open): Likewise.
	(create_and_call): Push/pop program state around call to external.
	(parser_entry): Implement new ENTRY statement feature.
	(mh_source_is_literalN): Formatting.
	* genapi.h (parser_entry): New ENTRY statement.
	* gengen.cc (gg_create_goto_pair): Formatting.
	(gg_goto_label_decl): Remove.
	* gengen.h (gg_goto_label_decl): Remove.
	* genutil.cc (internal_codeset_is_ebcdic): Remove.
	* genutil.h (internal_codeset_is_ebcdic): Remove.
	* symbols.cc (symbols_alphabet_set): Restrict alphabet scan to
	program.
	* symbols.h (is_elementary): Use defined constants instead of
	explicit 'A'and 'N'

libgcobol/ChangeLog:

	* charmaps.cc (__gg__set_internal_codeset): Eliminate ascii/ebcdic.
	(__gg__text_conversion_override): Remove.
	* charmaps.h (enum text_device_t):  Eliminate ascii/ebcdic.
	(enum text_codeset_t): Remove.
	(__gg__set_internal_codeset): Remove.
	(__gg__text_conversion_override): Remove.
	* gfileio.cc: Anticipate cbl_encoding_t fixes.
	* libgcobol.cc (struct program_state): Incorporate
	__gg__entry_label.
	(__gg__pop_program_state): Eliminate unused defines.
	(__gg__alphabet_use): Eliminate ascii/ebcdic dichotomy.
	* valconv.cc (__gg__alphabet_create): Likewise.
This commit is contained in:
Robert Dubner 2025-10-18 10:35:52 -04:00
parent 5d110ed194
commit 85750fb8c2
13 changed files with 445 additions and 458 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

704
gcc/cobol/genapi.cc
View File

@ -2357,7 +2357,7 @@ static void
move_tree( cbl_field_t *dest,
tree offset,
tree psz_source, // psz_source is a null-terminated string
tree length_bump=integer_zero_node)
tree length_bump=integer_zero_node)
{
// This routine assumes that the psz_source is in the same codeset as the
// dest.
@ -3774,6 +3774,7 @@ parser_enter_file(const char *filename)
SET_VAR_DECL(var_decl_treeplet_4s , SIZE_T_P , "__gg__treeplet_4s" );
SET_VAR_DECL(var_decl_nop , INT , "__gg__nop" );
SET_VAR_DECL(var_decl_main_called , INT , "__gg__main_called" );
SET_VAR_DECL(var_decl_entry_label , VOID_P , "__gg__entry_label" );
}
}
@ -3865,25 +3866,6 @@ enter_program_common(const char *funcname, const char *funcname_)
current_function->current_section = NULL;
current_function->current_paragraph = NULL;
// Text conversion must be initialized before the code generated by
// parser_symbol_add runs.
// The text_conversion_override exists both in the library and in the compiler
__gg__set_internal_codeset(internal_codeset_is_ebcdic());
gg_call(VOID,
"__gg__set_internal_codeset",
internal_codeset_is_ebcdic()
? integer_one_node : integer_zero_node,
NULL_TREE);
__gg__text_conversion_override(td_default_e, cs_default_e);
gg_call(VOID,
"__gg__text_conversion_override",
build_int_cst_type(INT, td_default_e),
build_int_cst_type(INT, cs_default_e),
NULL_TREE);
gg_call(VOID,
"__gg__codeset_figurative_constants",
NULL_TREE);
@ -5059,29 +5041,34 @@ parser_alphabet( cbl_alphabet_t& alphabet )
SHOW_PARSE
{
SHOW_PARSE_HEADER
fprintf(stderr, "%s\n", alphabet.name);
char *psz = xasprintf(" %s ", alphabet.name);
SHOW_PARSE_TEXT(psz);
free(psz);
switch(alphabet.encoding)
{
case ASCII_e:
fprintf(stderr, "ASCII\n");
psz = xasprintf("ASCII");
break;
case iso646_e:
fprintf(stderr, "ISO646\n");
psz = xasprintf("ISO646");
break;
case EBCDIC_e:
fprintf(stderr, "EBCDIC\n");
psz = xasprintf("EBCDIC");
break;
case UTF8_e:
fprintf(stderr, "UTF8\n");
psz = xasprintf("UTF8");
break;
case custom_encoding_e:
fprintf(stderr, "%s\n", alphabet.name);
psz = xasprintf("%s", alphabet.name);
break;
default:
{ const char * p = __gg__encoding_iconv_name( alphabet.encoding );
fprintf(stderr, "%s\n", p? p : "[unknown]");
psz = xasprintf("%s", p? p : "[unknown]");
}
}
SHOW_PARSE_TEXT(" ");
SHOW_PARSE_TEXT(psz);
free(psz);
SHOW_PARSE_END
}
@ -5122,6 +5109,7 @@ parser_alphabet( cbl_alphabet_t& alphabet )
gg_get_address_of(table256),
build_int_cst_type(INT, alphabet.low_index),
build_int_cst_type(INT, alphabet.high_index),
NULL_TREE );
break;
}
@ -5137,26 +5125,31 @@ parser_alphabet_use( cbl_alphabet_t& alphabet )
SHOW_PARSE
{
SHOW_PARSE_HEADER
char *psz = xasprintf(" %s ", alphabet.name);
SHOW_PARSE_TEXT(psz);
free(psz);
switch(alphabet.encoding)
{
case ASCII_e:
fprintf(stderr, "ASCII\n");
psz = xasprintf("ASCII");
break;
case iso646_e:
fprintf(stderr, "ISO646\n");
psz = xasprintf("ISO646");
break;
case EBCDIC_e:
fprintf(stderr, "EBCDIC\n");
psz = xasprintf("EBCDIC");
break;
case UTF8_e:
fprintf(stderr, "UTF8\n");
psz = xasprintf("UTF8");
break;
case custom_encoding_e:
fprintf(stderr, "%s\n", alphabet.name);
psz = xasprintf("%s", alphabet.name);
break;
default:
gcc_unreachable();
}
SHOW_PARSE_TEXT(psz);
free(psz);
SHOW_PARSE_END
}
@ -5174,6 +5167,7 @@ parser_alphabet_use( cbl_alphabet_t& alphabet )
__gg__high_value_character = DEGENERATE_HIGH_VALUE;
gg_call(VOID,
"__gg__alphabet_use",
build_int_cst_type(INT, current_encoding(encoding_display_e)),
build_int_cst_type(INT, alphabet.encoding),
null_pointer_node,
NULL_TREE);
@ -5189,6 +5183,7 @@ parser_alphabet_use( cbl_alphabet_t& alphabet )
gg_call(VOID,
"__gg__alphabet_use",
build_int_cst_type(INT, current_encoding(encoding_display_e)),
build_int_cst_type(INT, alphabet.encoding),
build_int_cst_type(SIZE_T, alphabet_index),
NULL_TREE);
@ -6938,6 +6933,7 @@ initialize_the_data()
// This is one-time initialization of the libgcobol program state stack
gg_call(VOID,
"__gg__init_program_state",
build_int_cst_type(INT, current_encoding(encoding_display_e)),
NULL_TREE);
__gg__currency_signs = __gg__ct_currency_signs;
@ -6989,6 +6985,280 @@ initialize_the_data()
}
}
static
void
establish_using(size_t nusing,
cbl_ffi_arg_t args[] )
{
if( nusing )
{
for(size_t i=0; i<nusing; i++)
{
// This code is relevant at compile time. It takes each
// expected formal parameter and tacks it onto the end of the
// function's arguments chain.
char *ach = xasprintf("_p_%s", args[i].refer.field->name);
size_t nbytes = 0;
tree par_type = tree_type_from_field_type(args[i].refer.field, nbytes);
if( par_type == FLOAT )
{
par_type = SSIZE_T;
}
if( par_type == DOUBLE )
{
par_type = SSIZE_T;
}
if( par_type == FLOAT128 )
{
par_type = INT128;
}
chain_parameter_to_function(current_function->function_decl, par_type, ach);
free(ach);
}
// During the call, we saved the parameter_count and an array of variable
// lengths. We need to look at those values if, and only if, one or more
// of our USING arguments has an OPTIONAL flag or if one of our targets is
// marked as VARYING.
bool check_for_parameter_count = false;
for(size_t i=0; i<nusing; i++)
{
if( args[i].optional )
{
check_for_parameter_count = true;
break;
}
if( args[i].refer.field->attr & any_length_e )
{
check_for_parameter_count = true;
break;
}
}
if( check_for_parameter_count )
{
IF( var_decl_call_parameter_signature,
eq_op,
gg_cast(CHAR_P, current_function->function_address) )
{
// We know to use var_decl_call_parameter_count, so unflag this
// pointer to avoid problems in the ridiculous possibility of
// COBOL-A calls C_B calls COBOL_A
gg_assign(var_decl_call_parameter_signature,
gg_cast(CHAR_P, null_pointer_node));
}
ELSE
{
// We were apparently called by a C routine, not a COBOL routine, so
// make sure we don't get shortchanged by a count left behind from an
// earlier COBOL call.
gg_assign(var_decl_call_parameter_count,
build_int_cst_type(INT, A_ZILLION));
}
ENDIF
}
else
{
// None of our parameters require a count, so make sure we don't get
// bamboozled by a count left behind from an earlier COBOL call.
gg_assign(var_decl_call_parameter_count,
build_int_cst_type(INT, A_ZILLION));
}
// There are 'nusing' elements in the PROCEDURE DIVISION USING list.
tree parameter = NULL_TREE;
tree rt_i = gg_define_int();
for(size_t i=0; i<nusing; i++)
{
// And this compiler code generates run-time execution code. The
// generated code picks up, at run time, the variable we just
// established in the chain at compile time.
// It makes more sense if you don't think about it too hard.
// We need to be able to restore prior arguments when doing recursive
// calls:
IF( member(args[i].refer.field->var_decl_node, "data"),
ne_op,
gg_cast(UCHAR_P, null_pointer_node) )
{
gg_call(VOID,
"__gg__push_local_variable",
gg_get_address_of(args[i].refer.field->var_decl_node),
NULL_TREE);
}
ELSE
ENDIF
tree base = gg_define_variable(UCHAR_P);
gg_assign(rt_i, build_int_cst_type(INT, i));
//gg_printf("The rt_i counter is %d\n", rt_i, NULL_TREE);
IF( rt_i, lt_op , var_decl_call_parameter_count )
{
if( i == 0 )
{
// This is the first parameter.
parameter = DECL_ARGUMENTS(current_function->function_decl);
}
else
{
// These are subsequent parameters
parameter = TREE_CHAIN(parameter);
}
gg_assign(base, gg_cast(UCHAR_P, parameter));
if( args[i].refer.field->attr & any_length_e )
{
// gg_printf("side channel: Length of \"%s\" is %ld\n",
// member(args[i].refer.field->var_decl_node, "name"),
// gg_array_value(var_decl_call_parameter_lengths, rt_i),
// NULL_TREE);
// Get the length from the global lengths[] side channel. Don't
// forget to use the length mask on the table value.
gg_assign(member(args[i].refer.field->var_decl_node, "capacity"),
gg_array_value(var_decl_call_parameter_lengths, rt_i));
}
}
ELSE
{
gg_assign(base, gg_cast(UCHAR_P, null_pointer_node));
}
ENDIF
// Arriving here means that we are processing an instruction like
// this:
// PROCEDURE DIVISION USING using[0] using[1] ... using using[nusing-1]
// When __gg__call_parameter_count is equal to A_ZILLION, then this is
// an OTHER-TO-COBOL call and the var_decl_call_parameter_lengths array
// is not valid
cbl_ffi_crv_t crv = args[i].crv;
cbl_field_t *new_var = args[i].refer.field;
if( crv == by_value_e )
{
switch(new_var->type)
{
case FldGroup:
case FldAlphanumeric:
case FldAlphaEdited:
case FldNumericEdited:
crv = by_reference_e;
break;
default:
break;
}
}
if( crv == by_value_e )
{
// 'parameter' is the 64-bit or 128-bit value that was placed on the stack
size_t nbytes;
tree_type_from_field_type(new_var, nbytes);
tree parm = gg_define_variable(INT128);
if( nbytes <= 8 )
{
// Our input is a 64-bit number
if( new_var->attr & signable_e )
{
IF( gg_bitwise_and( gg_cast(SIZE_T, base),
build_int_cst_type(SIZE_T, 0x8000000000000000ULL)),
ne_op,
gg_cast(SIZE_T, integer_zero_node) )
{
// Our input is a negative number
gg_assign(parm, gg_cast(INT128, integer_minus_one_node));
}
ELSE
{
// Our input is a positive number
gg_assign(parm, gg_cast(INT128, integer_zero_node));
}
ENDIF
}
else
{
// This is a 64-bit positive number:
gg_assign(parm, gg_cast(INT128, integer_zero_node));
}
}
// At this point, parm has been set to 0 or -1
gg_memcpy(gg_get_address_of(parm),
gg_get_address_of(base),
build_int_cst_type(SIZE_T, nbytes));
tree array_type = build_array_type_nelts(UCHAR, new_var->data.capacity);
tree data_decl_node = gg_define_variable( array_type,
NULL,
vs_static);
gg_assign( member(new_var->var_decl_node, "data"),
gg_get_address_of(data_decl_node) );
// And then move it into place
gg_call(VOID,
"__gg__assign_value_from_stack",
gg_get_address_of(new_var->var_decl_node),
parm,
NULL_TREE);
// We now have to handle an oddball situation. It's possible we are
// dealing with
//
// linkage section.
// 01 var1
// 01 var2 redefines var1
//
// If so, we have to give var2::data_pointer the same value as
// var1::data_pointer
//
size_t our_index = symbol_index(symbol_elem_of(new_var));
size_t next_index = our_index + 1;
// Look ahead in the symbol table for the next LEVEL01/77
for(;;)
{
symbol_elem_t *e = symbol_at(next_index);
if( e->type != SymField )
{
break;
}
cbl_field_t *next_var = cbl_field_of(e);
if( !next_var )
{
break;
}
if( next_var->level == LEVEL01 || next_var->level == LEVEL77 )
{
if( next_var->parent == our_index )
{
gg_assign(member(next_var->var_decl_node, "data"),
member(new_var->var_decl_node, "data"));
}
break;
}
next_index += 1;
}
}
else
{
// 'parameter' is a reference, so it it becomes the data member of
// the cblc_field_t COBOL variable.
gg_assign(member(args[i].field()->var_decl_node, "data"), base);
// We need to apply base + offset to the LINKAGE variable
// and all of its children
propogate_linkage_offsets( args[i].field(), base );
}
}
}
}
void
parser_division(cbl_division_t division,
cbl_field_t *returning,
@ -7187,273 +7457,6 @@ parser_division(cbl_division_t division,
// length. We establish those lengths based on the types of the target
// for each USING.
for(size_t i=0; i<nusing; i++)
{
// This code is relevant at compile time. It takes each
// expected formal parameter and tacks it onto the end of the
// function's arguments chain.
sprintf(ach, "_p_%s", args[i].refer.field->name);
size_t nbytes = 0;
tree par_type = tree_type_from_field_type(args[i].refer.field, nbytes);
if( par_type == FLOAT )
{
par_type = SSIZE_T;
}
if( par_type == DOUBLE )
{
par_type = SSIZE_T;
}
if( par_type == FLOAT128 )
{
par_type = INT128;
}
chain_parameter_to_function(current_function->function_decl, par_type, ach);
}
if( nusing )
{
// During the call, we saved the parameter_count and an array of variable
// lengths. We need to look at those values if, and only if, one or more
// of our USING arguments has an OPTIONAL flag or if one of our targets is
// marked as VARYING.
bool check_for_parameter_count = false;
for(size_t i=0; i<nusing; i++)
{
if( args[i].optional )
{
check_for_parameter_count = true;
break;
}
if( args[i].refer.field->attr & any_length_e )
{
check_for_parameter_count = true;
break;
}
}
if( check_for_parameter_count )
{
IF( var_decl_call_parameter_signature,
eq_op,
gg_cast(CHAR_P, current_function->function_address) )
{
// We know to use var_decl_call_parameter_count, so unflag this
// pointer to avoid problems in the ridiculous possibility of
// COBOL-A calls C_B calls COBOL_A
gg_assign(var_decl_call_parameter_signature,
gg_cast(CHAR_P, null_pointer_node));
}
ELSE
{
// We were apparently called by a C routine, not a COBOL routine, so
// make sure we don't get shortchanged by a count left behind from an
// earlier COBOL call.
gg_assign(var_decl_call_parameter_count,
build_int_cst_type(INT, A_ZILLION));
}
ENDIF
}
else
{
// None of our parameters require a count, so make sure we don't get
// bamboozled by a count left behind from an earlier COBOL call.
gg_assign(var_decl_call_parameter_count,
build_int_cst_type(INT, A_ZILLION));
}
// There are 'nusing' elements in the PROCEDURE DIVISION USING list.
tree parameter = NULL_TREE;
tree rt_i = gg_define_int();
for(size_t i=0; i<nusing; i++)
{
// And this compiler code generates run-time execution code. The
// generated code picks up, at run time, the variable we just
// established in the chain at compile time.
// It makes more sense if you don't think about it too hard.
// We need to be able to restore prior arguments when doing recursive
// calls:
IF( member(args[i].refer.field->var_decl_node, "data"),
ne_op,
gg_cast(UCHAR_P, null_pointer_node) )
{
gg_call(VOID,
"__gg__push_local_variable",
gg_get_address_of(args[i].refer.field->var_decl_node),
NULL_TREE);
}
ELSE
ENDIF
tree base = gg_define_variable(UCHAR_P);
gg_assign(rt_i, build_int_cst_type(INT, i));
//gg_printf("The rt_i counter is %d\n", rt_i, NULL_TREE);
IF( rt_i, lt_op , var_decl_call_parameter_count )
{
if( i == 0 )
{
// This is the first parameter.
parameter = DECL_ARGUMENTS(current_function->function_decl);
}
else
{
// These are subsequent parameters
parameter = TREE_CHAIN(parameter);
}
gg_assign(base, gg_cast(UCHAR_P, parameter));
if( args[i].refer.field->attr & any_length_e )
{
// gg_printf("side channel: Length of \"%s\" is %ld\n",
// member(args[i].refer.field->var_decl_node, "name"),
// gg_array_value(var_decl_call_parameter_lengths, rt_i),
// NULL_TREE);
// Get the length from the global lengths[] side channel. Don't
// forget to use the length mask on the table value.
gg_assign(member(args[i].refer.field->var_decl_node, "capacity"),
gg_array_value(var_decl_call_parameter_lengths, rt_i));
}
}
ELSE
{
gg_assign(base, gg_cast(UCHAR_P, null_pointer_node));
}
ENDIF
// Arriving here means that we are processing an instruction like
// this:
// PROCEDURE DIVISION USING using[0] using[1] ... using using[nusing-1]
// When __gg__call_parameter_count is equal to A_ZILLION, then this is
// an OTHER-TO-COBOL call and the var_decl_call_parameter_lengths array
// is not valid
cbl_ffi_crv_t crv = args[i].crv;
cbl_field_t *new_var = args[i].refer.field;
if( crv == by_value_e )
{
switch(new_var->type)
{
case FldGroup:
case FldAlphanumeric:
case FldAlphaEdited:
case FldNumericEdited:
crv = by_reference_e;
break;
default:
break;
}
}
if( crv == by_value_e )
{
// 'parameter' is the 64-bit or 128-bit value that was placed on the stack
size_t nbytes;
tree_type_from_field_type(new_var, nbytes);
tree parm = gg_define_variable(INT128);
if( nbytes <= 8 )
{
// Our input is a 64-bit number
if( new_var->attr & signable_e )
{
IF( gg_bitwise_and( gg_cast(SIZE_T, base),
build_int_cst_type(SIZE_T, 0x8000000000000000ULL)),
ne_op,
gg_cast(SIZE_T, integer_zero_node) )
{
// Our input is a negative number
gg_assign(parm, gg_cast(INT128, integer_minus_one_node));
}
ELSE
{
// Our input is a positive number
gg_assign(parm, gg_cast(INT128, integer_zero_node));
}
ENDIF
}
else
{
// This is a 64-bit positive number:
gg_assign(parm, gg_cast(INT128, integer_zero_node));
}
}
// At this point, parm has been set to 0 or -1
gg_memcpy(gg_get_address_of(parm),
gg_get_address_of(base),
build_int_cst_type(SIZE_T, nbytes));
tree array_type = build_array_type_nelts(UCHAR, new_var->data.capacity);
tree data_decl_node = gg_define_variable( array_type,
NULL,
vs_static);
gg_assign( member(new_var->var_decl_node, "data"),
gg_get_address_of(data_decl_node) );
// And then move it into place
gg_call(VOID,
"__gg__assign_value_from_stack",
gg_get_address_of(new_var->var_decl_node),
parm,
NULL_TREE);
// We now have to handle an oddball situation. It's possible we are
// dealing with
//
// linkage section.
// 01 var1
// 01 var2 redefines var1
//
// If so, we have to give var2::data_pointer the same value as
// var1::data_pointer
//
size_t our_index = symbol_index(symbol_elem_of(new_var));
size_t next_index = our_index + 1;
// Look ahead in the symbol table for the next LEVEL01/77
for(;;)
{
symbol_elem_t *e = symbol_at(next_index);
if( e->type != SymField )
{
break;
}
cbl_field_t *next_var = cbl_field_of(e);
if( !next_var )
{
break;
}
if( next_var->level == LEVEL01 || next_var->level == LEVEL77 )
{
if( next_var->parent == our_index )
{
gg_assign(member(next_var->var_decl_node, "data"),
member(new_var->var_decl_node, "data"));
}
break;
}
next_index += 1;
}
}
else
{
// 'parameter' is a reference, so it it becomes the data member of
// the cblc_field_t COBOL variable.
gg_assign(member(args[i].field()->var_decl_node, "data"), base);
// We need to apply base + offset to the LINKAGE variable
// and all of its children
propogate_linkage_offsets( args[i].field(), base );
}
}
}
gg_call(VOID,
"__gg__pseudo_return_bookmark",
NULL_TREE);
@ -7504,6 +7507,25 @@ parser_division(cbl_division_t division,
// logic for backing up one line, which is needed to correctly step through
// COBOL code with GDB-COBOL. So, we clear it here.
current_location_minus_one_clear();
// It is at this point that we check to see if the call to this function
// is a re-entry because of an ENTRY statement:
IF( var_decl_entry_label, ne_op, null_pointer_node )
{
// This is an ENTRY re-entry. The processing of USING variables was
// done in parser_entry, so now we jump to the label
static tree loc = gg_define_variable(VOID_P, vs_static);
gg_assign(loc, var_decl_entry_label);
gg_assign(var_decl_entry_label, gg_cast(VOID_P, null_pointer_node));
gg_goto(loc);
}
ELSE
{
}
ENDIF
establish_using(nusing, args);
}
}
@ -9683,7 +9705,10 @@ parser_file_add(struct cbl_file_t *file)
build_int_cst_type(INT, (int)file->optional),
build_int_cst_type(SIZE_T, varies.min),
build_int_cst_type(SIZE_T, varies.max),
build_int_cst_type(INT, (int)file->codeset.encoding),
/* Right now, file->codeset.encoding is not being set properly. Remove this
comment and fix the following code when that's repaired. */
// build_int_cst_type(INT, (int)file->codeset.encoding),
build_int_cst_type(INT, current_encoding(encoding_display_e)),
build_int_cst_type(INT, (int)file->codeset.alphabet),
NULL_TREE);
file->var_decl_node = new_var_decl;
@ -9776,7 +9801,7 @@ parser_file_open( struct cbl_file_t *file, int mode_char )
gg_call( CHAR_P,
"__gg__convert_encoding",
psz,
build_int_cst_type(INT,
build_int_cst_type(INT,
field_of_name->codeset.encoding),
build_int_cst_type(INT,
DEFAULT_CHARMAP_SOURCE),
@ -13274,7 +13299,9 @@ create_and_call(size_t narg,
{
// Because no explicit returning value is expected, we just call it. We
// expect COBOL routines to set RETURN-CODE when they think it necessary.
push_program_state();
gg_append_statement(call_expr);
pop_program_state();
}
for( size_t i=0; i<narg; i++ )
@ -13482,10 +13509,79 @@ parser_entry_activate( size_t iprog, const cbl_label_t *declarative )
assert(iprog == symbol_elem_of(declarative)->program);
}
// Define ENTRY point with alternative LINKAGE
static tree entry_goto;
static tree entry_label;
static tree entry_addr;
void
parser_entry( cbl_field_t */*name*/, size_t /*narg*/, cbl_ffi_arg_t */*args*/ )
parser_entry( const cbl_field_t *name, size_t nusing, cbl_ffi_arg_t *args )
{
// We are implementing the ENTRY statement, which creates an alternative
// entry point into the current program-id. There is no actual way to do
// that literally. So, we are going to create a separate routine that sets
// things up and then calls the current routine with the information it needs
// to transfer processing to the ENTRY point.
SHOW_PARSE
{
SHOW_PARSE_HEADER
SHOW_PARSE_FIELD( " ENTRY ", name)
SHOW_PARSE_END
}
// Get the name of the program that contains the ENTRY statement.
char *name_of_parent = xstrdup(current_function->our_name);
// Get the name of the ENTRY point.
// cppcheck-suppress nullPointerRedundantCheck
char *psz = cobol_name_mangler(name->data.initial);
// Create a goto/label pair. The label will be set up here; the goto will
// be used when we re-enter the containing function:
gg_create_goto_pair(&entry_goto,
&entry_label,
&entry_addr);
// Start creating the ENTRY function.
tree function_decl = gg_define_function( VOID,
psz,
psz,
NULL_TREE);
free(psz);
// Modify the default settings for this entry point
TREE_ADDRESSABLE(function_decl) = 0;
TREE_USED(function_decl) = 0;
TREE_NOTHROW(function_decl) = 0;
TREE_STATIC(function_decl) = 1;
DECL_EXTERNAL (function_decl) = 0;
TREE_PUBLIC (function_decl) = 1;
DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT(function_decl) = 1;
// When the ENTRY function point is called, we process its "using"
// parameters:
establish_using(nusing, args);
// Put the entry_label into the global variable that will be picked up
// when the containing program-id is re-entered:
gg_assign(var_decl_entry_label, entry_addr);
// Get the function address of the containing function.
tree gfa = gg_get_function_address(VOID, name_of_parent);
free(name_of_parent);
// Call the containing function
gg_append_statement(gg_call_expr_list(VOID,
gfa,
0,
NULL));
// We are done with the ENTRY function:
gg_finalize_function();
// Lay down the address of the label that matches var_decl_entry_label;
// the containing program-id will jump to this point.
gg_append_statement(entry_label);
}
void
@ -14522,7 +14618,7 @@ mh_source_is_literalN(cbl_refer_t &destref,
// __gg__string_to_alpha_edited expects the source string to be in
// the same encoding as the target:
size_t len = strlen(sourceref.field->data.initial);
char *src =
char *src =
static_cast<char *>(xmalloc(len+1));
memcpy( src,
sourceref.field->data.initial,

5
gcc/cobol/genapi.h
View File

@ -558,8 +558,9 @@ void parser_call( cbl_refer_t name,
void parser_entry_activate( size_t iprog, const cbl_label_t *declarative );
void parser_entry( cbl_field_t *name,
size_t narg = 0, cbl_ffi_arg_t args[] = NULL);
void parser_entry( const cbl_field_t *name,
size_t narg = 0,
cbl_ffi_arg_t args[] = NULL);
bool is_ascending_key(const cbl_refer_t& key);

15
gcc/cobol/gengen.cc
View File

@ -1830,7 +1830,10 @@ gg_build_logical_expression(tree operand_a,
}
void
gg_create_goto_pair(tree *goto_expr, tree *label_expr, tree *label_addr, const char *name)
gg_create_goto_pair(tree *goto_expr,
tree *label_expr,
tree *label_addr,
const char *name)
{
// We are going to create a pair of expressions for our
// caller. They are a matched set of goto/label expressions,
@ -1886,16 +1889,6 @@ gg_create_goto_pair(tree *goto_expr,
*label_addr = gg_get_address_of(*label_decl);
}
void
gg_goto_label_decl(tree label_decl)
{
tree goto_expr = build1_loc( gg_token_location(),
GOTO_EXPR,
void_type_node,
label_decl);
gg_append_statement(goto_expr);
}
void
gg_create_goto_pair(tree *goto_expr, tree *label_expr)
{

1
gcc/cobol/gengen.h
View File

@ -495,7 +495,6 @@ void gg_create_goto_pair( tree *goto_expr,
tree *label_expr,
tree *label_addr,
tree *label_decl);
void gg_goto_label_decl(tree label_decl);
// Used for implementing SECTIONS and PARAGRAPHS. When you have a
// void *pointer = &&label, gg_goto is the same as

7
gcc/cobol/genutil.cc
View File

@ -50,8 +50,6 @@
#include "../../libgcobol/exceptl.h"
#include "exceptg.h"
bool internal_codeset_is_ebcdic() { return gcobol_feature_internal_ebcdic(); }
bool exception_location_active = true;
bool skip_exception_processing = true;
@ -107,8 +105,13 @@ tree var_decl_treeplet_4s; // SIZE_T_P , "__gg__treeplet_4s"
// wasn't successful figuring out how to create an actual NOP assembly language
// instruction, I instead gg_assign(var_decl_nop, integer_zero_node)
tree var_decl_nop; // int __gg__nop;
// Indicates which routine main() called
tree var_decl_main_called; // int __gg__main_called;
// Indicates the target label for an ENTRY statement
tree var_decl_entry_label; // void* __gg__entry_label
#if 0
#define REFER(a)
#else

4
gcc/cobol/genutil.h
View File

@ -30,8 +30,6 @@
#ifndef _GENUTIL_H_
#define _GENUTIL_H_
bool internal_codeset_is_ebcdic();
extern bool exception_location_active;
extern bool skip_exception_processing;
@ -79,9 +77,9 @@ extern tree var_decl_treeplet_3s; // SIZE_T_P , "__gg__treeplet_3
extern tree var_decl_treeplet_4f; // cblc_field_pp_type_node , "__gg__treeplet_4f"
extern tree var_decl_treeplet_4o; // SIZE_T_P , "__gg__treeplet_4o"
extern tree var_decl_treeplet_4s; // SIZE_T_P , "__gg__treeplet_4s"
extern tree var_decl_nop; // int __gg__nop
extern tree var_decl_main_called; // int __gg__main_called
extern tree var_decl_entry_label; // void* __gg__entry_label
int get_scaled_rdigits(cbl_field_t *field);
int get_scaled_digits(cbl_field_t *field);

2
gcc/cobol/symbols.cc
View File

@ -1643,7 +1643,7 @@ symbols_alphabet_set( size_t program, const char name[]) {
};
// Define alphabets for codegen.
std::for_each(symbols_begin(), symbols_end(), alpha() );
std::for_each(symbols_begin(program), symbols_end(), alpha() );
// Set collation sequence before parser_symbol_add.
if( name ) {

7
gcc/cobol/symbols.h
View File

@ -503,6 +503,13 @@ const char * __gg__encoding_iconv_name( cbl_encoding_t encoding );
bool is_elementary( enum cbl_field_type_t type );
// These were introduced to discourage the use of
// current_encoding('A') and current_encoding('N')
enum
{
encoding_display_e = 'A',
encoding_national_e = 'N'
};
cbl_encoding_t current_encoding( char a_or_n );
/* In cbl_field_t:

75
libgcobol/charmaps.cc
View File

@ -94,13 +94,6 @@ char *__gg__ct_currency_signs[256]; // Compile-time currency signs
// And we will take some pains to figure out if the source code file was done
// as UTF-8; if not, we will assume 1252/8859-1
// __gg__ebcdic_codeset_in_use is the ultimate determinator of whether the
// internal codeset is ASCII/CP1252 or EBCDIC/CP1140.
bool __gg__ebcdic_codeset_in_use = false ;
static text_codeset_t source_codeset = cs_cp1252_e;
static text_codeset_t console_codeset = cs_default_e;
#define UNICODE_REPLACEMENT 0xFFFD // This a white question mark in a black diamond
#define ASCII_REPLACEMENT 0x87 // In CP1252, 0x87 is a double-dagger
@ -235,74 +228,6 @@ __gg__ebcdic_to_cp1252_collation[256] =
0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0xB3, 0xDB, 0xDC, 0xD9, 0xDA, 0xFF,
};
// Here is the list of function pointers establish which ones of the paired
// possibilities of conversion routines are actually in use.
extern "C"
void __gg__set_internal_codeset(int use_ebcdic)
{
__gg__ebcdic_codeset_in_use = !!use_ebcdic;
}
extern "C"
void __gg__text_conversion_override(text_device_t device,
text_codeset_t codeset)
{
// Establish the default sourcecode and console codesets, and
// establish the codeset conversion routines:
switch(device)
{
case td_default_e:
{
// We are setting our codesets to the defaults
// First, sort out the console:
// It is my understanding that the environment variable LANG is
// supposed to be set by the terminal to indicate the terminal's
// current character set. Let's use that as the winner, even if
// that's not quite the way locale(3) works.
const char *envLANG = getenv("LANG");
if( !envLANG )
{
// This is odd. No "LANG"?
envLANG = setlocale(LC_CTYPE, NULL);
}
if( !envLANG )
{
// This is even more odd. Pick something as a backup to the backup
envLANG = "UTF-8";
}
if( envLANG )
{
if( strcasestr(envLANG, "UTF-8") )
{
console_codeset = cs_utf8_e;
}
else
{
// If it isn't UTF-8, then figure on it being CP1252 as a
// convenient way of specifying an SBC codeset.
console_codeset = cs_cp1252_e;
}
}
break;
}
case td_sourcecode_e:
// Explicitly set the source code codeset:
source_codeset = codeset;
break;
case td_console_e:
// Explicitly set the console codeset:
console_codeset = codeset;
break;
}
}
static encodings_t encodings[] = {
{ iconv_437_e, "437" },
{ iconv_500_e, "500" },

30
libgcobol/charmaps.h
View File

@ -112,8 +112,6 @@ extern char **__gg__currency_signs ;
extern int __gg__default_currency_sign;
extern char *__gg__ct_currency_signs[256]; // Compile-time currency signs
extern bool __gg__ebcdic_codeset_in_use;
#define NULLCH ('\0')
#define DEGENERATE_HIGH_VALUE 0xFF
#define DEGENERATE_LOW_VALUE 0x00
@ -202,21 +200,6 @@ extern bool __gg__ebcdic_codeset_in_use;
#define ascii_newline ((uint8_t)('\n'))
#define ascii_return ((uint8_t)('\r'))
enum text_device_t
{
td_default_e,
td_sourcecode_e,
td_console_e,
};
enum text_codeset_t
{
cs_default_e,
cs_utf8_e,
cs_cp1252_e,
cs_cp1140_e
};
extern unsigned char __gg__data_space[1] ;
extern unsigned char __gg__data_low_values[1] ;
extern unsigned char __gg__data_zeros[1] ;
@ -234,19 +217,6 @@ extern const unsigned short __gg__cp1140_to_cp1252_values[256];
extern const unsigned short __gg__cp1252_to_ebcdic_collation[256];
extern const unsigned short __gg__ebcdic_to_cp1252_collation[256];
// As described above, we have a number of operations we need to accomplish. But
// the actual routines are dependent on whether EBCDIC or ASCII is in use. We
// implement that by having a function pointer for each function; those pointers
// are established when the __gg__ebcdic_codeset_in_use variable is established.
// These routines convert a single ASCII character to either ASCII or EBCDIC
extern "C" void __gg__set_internal_codeset(int use_ebcdic);
extern "C"
void __gg__text_conversion_override(text_device_t device,
text_codeset_t codeset);
const char * __gg__encoding_iconv_name( cbl_encoding_t encoding );
cbl_encoding_t __gg__encoding_iconv_type( const char *name );

6
libgcobol/gfileio.cc
View File

@ -330,12 +330,6 @@ __gg__file_init(
{
if( !(file->flags & file_flag_initialized_e) )
{
if( encoding != iconv_CP1140_e && __gg__ebcdic_codeset_in_use )
{
// This code is to be eliminated when 'encoding' is valid.
encoding = iconv_CP1140_e;
}
charmap_t *charmap = __gg__get_charmap(encoding);
file->name = strdup(name);

44
libgcobol/libgcobol.cc
View File

@ -139,6 +139,7 @@ int __gg__default_compute_error = 0 ;
int __gg__rdigits = 0 ;
int __gg__nop = 0 ;
int __gg__main_called = 0 ;
void *__gg__entry_label = NULL ;
cbl_encoding_t __gg__console_encoding = no_encoding_e ;
// During SORT operations, we don't want the end-of-file condition, which
@ -484,16 +485,7 @@ struct program_state
memset(rt_currency_signs, 0, sizeof(rt_currency_signs));
// The default collating sequence:
if( __gg__ebcdic_codeset_in_use )
{
rt_collation = __gg__cp1140_to_cp1252_values;
}
else
{
rt_collation = __gg__one_to_one_values;
}
// rt_collation = __gg__one_to_one_values;
rt_collation = __gg__one_to_one_values;
rt_program_name = NULL;
}
@ -694,21 +686,13 @@ void
__gg__pop_program_state()
{
program_states.pop_back();
// #define decimal_point (program_states.back().rt_decimal_point)
// #define decimal_separator (program_states.back().rt_decimal_separator)
// #define quote_character (program_states.back().rt_quote_character)
// #define low_value_character (program_states.back().rt_low_value_character)
// #define high_value_character (program_states.back().rt_high_value_character)
__gg__decimal_point = program_states.back().rt_decimal_point ;
__gg__decimal_separator = program_states.back().rt_decimal_separator ;
__gg__quote_character = program_states.back().rt_quote_character ;
__gg__low_value_character = program_states.back().rt_low_value_character ;
__gg__high_value_character = program_states.back().rt_high_value_character ;
__gg__currency_signs = program_states.back().rt_currency_signs ;
}
}
static
int
@ -10733,7 +10717,8 @@ __gg__set_pointer(cblc_field_t *target,
extern "C"
void
__gg__alphabet_use( cbl_encoding_t encoding,
__gg__alphabet_use( cbl_encoding_t alphabetic_encoding,
cbl_encoding_t encoding,
size_t alphabet_index)
{
// We simply replace the values in the current program_state. If the
@ -10743,26 +10728,35 @@ __gg__alphabet_use( cbl_encoding_t encoding,
if( program_states.empty() )
{
// When there is no DATA DIVISION, program_states can be empty when
// we arrive here. So, we need to remedy that:
// we arrive here. So, we need to remedy that.
initialize_program_state();
}
const charmap_t *charmap_alphabetic = __gg__get_charmap(alphabetic_encoding);
switch( encoding )
{
case ASCII_e:
case iso646_e:
// This is one of the very common standard situations; where we are using
// something like a CP1252 Western European ASCII-like character set.
__gg__low_value_character = DEGENERATE_LOW_VALUE;
__gg__high_value_character = DEGENERATE_HIGH_VALUE;
program_states.back().rt_low_value_character = DEGENERATE_LOW_VALUE;
program_states.back().rt_high_value_character = DEGENERATE_HIGH_VALUE;
if( !__gg__ebcdic_codeset_in_use )
if( !charmap_alphabetic->is_like_ebcdic() )
{
// The codeset is ascii-like, and the collation is ascii, so we use
// one-to-one values:
program_states.back().rt_collation = __gg__one_to_one_values;
}
else
{
// The codeset is ebcdic-like, but the collation is specified as
// ascii-like. So, we need that collation:
program_states.back().rt_collation = __gg__ebcdic_to_cp1252_collation;
}
@ -10774,12 +10768,16 @@ __gg__alphabet_use( cbl_encoding_t encoding,
program_states.back().rt_low_value_character = DEGENERATE_LOW_VALUE;
program_states.back().rt_high_value_character = DEGENERATE_HIGH_VALUE;
if( __gg__ebcdic_codeset_in_use )
if( charmap_alphabetic->is_like_ebcdic() )
{
// The alphanumeric codeset is ebcdic-like, and so is the specified
// collation:
program_states.back().rt_collation = __gg__one_to_one_values;
}
else
{
// The alphanumeric codeset is ebcdic-like, but the specified collation
// is ascii-like:
program_states.back().rt_collation = __gg__cp1252_to_ebcdic_collation;
}
break;

3
libgcobol/valconv.cc
View File

@ -79,6 +79,9 @@ __gg__alphabet_create( cbl_encoding_t encoding,
if( it == __gg__alphabet_states.end() )
{
// This is an alphabet we don't know about. So just assume the collation
// is the same as the character ordering:
alphabet_state new_state;
new_state.low_char = low_char;
new_state.high_char = high_char;