diff --git a/gcc/cobol/compare.cc b/gcc/cobol/compare.cc
index d04aad45d52..f9910c98dd8 100644
--- a/gcc/cobol/compare.cc
+++ b/gcc/cobol/compare.cc
@@ -608,7 +608,13 @@ alpha_compare_figconst( tree &left,
__gg__get_charmap(left_side.field->codeset.encoding);
charmap_t *charmap_right =
__gg__get_charmap(right_side.field->codeset.encoding);
- cbl_char_t char_right =
charmap_right->figconst_character(figconst_right);
+
+ // We know the result of this mapping has to be an 8-bit value, because
+ // all figconsts map to a single byte. HIGH-VALUE is a bit of a
problem,
+ // but when is it not? It usually will be 0xFF in the low-order byte,
so
+ // that's what we assume for now.
+
+ uint8_t char_right = charmap_right->figconst_character(figconst_right);
size_t nbytes;
char *converted;
@@ -671,12 +677,12 @@ alpha_compare(tree &left,
charmap_t *charmap_left =
__gg__get_charmap(left_side.field->codeset.encoding);
cbl_figconst_t figconst_left
= (cbl_figconst_t)(left_side.field->attr &
FIGCONST_MASK);
- cbl_char_t char_left =
charmap_left->figconst_character(figconst_left);
+ uint8_t char_left = charmap_left->figconst_character(figconst_left);
charmap_t *charmap_right =
__gg__get_charmap(right_side.field->codeset.encoding);
cbl_figconst_t figconst_right
= (cbl_figconst_t)(right_side.field->attr &
FIGCONST_MASK);
- cbl_char_t char_right =
charmap_right->figconst_character(figconst_right);
+ uint8_t char_right = charmap_right->figconst_character(figconst_right);
tree location_left;
tree location_right;
@@ -792,8 +798,10 @@ alpha_compare(tree &left,
// R.J.Dubner; 2026-05-08
static const long MAGIC_NUMBER = 16;
- // We are going to need the space character in this encoding space:
- cbl_char_t space_char = charmap_left->mapped_character(ascii_space);
+ // We are going to need the space character in this encoding space.
We
+ // know the result of the mapping has to fit into a byte, so we do
that
+ // to make things work in both little-endian and big-endian.
+ uint8_t space_char = charmap_left->mapped_character(ascii_space);
const char *the_routine;
switch( charmap_left->stride() )
{
@@ -1017,7 +1025,7 @@ numeric_alpha_compare(tree &left,
__gg__get_charmap(right_side.field->codeset.encoding);
cbl_figconst_t figconst_right
= (cbl_figconst_t)(right_side.field->attr &
FIGCONST_MASK);
- cbl_char_t char_right =
charmap_right->figconst_character(figconst_right);
+ uint8_t char_right = charmap_right->figconst_character(figconst_right);
if( left_side.field->type == FldLiteralN )
{
@@ -1266,8 +1274,8 @@ float_compare(tree &left,
const cbl_refer_t &right_side)
{
// left is a float, and if right is also a float it is smaller than
left
+ tree type = tree_type_from_field(left_side.field);
get_binary_value(left, left_side);
- tree type = TREE_TYPE(left);
tree rightv;
get_binary_value(rightv, right_side, type);
right = gg_define_variable(type);
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index d0482c2f4d6..3e2b251969b 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -2348,9 +2348,10 @@ parser_alter( cbl_perform_tgt_t *tgt )
}
void
-parser_goto( cbl_refer_t value_ref, size_t narg, cbl_label_t * const
labels[] )
- // This routine takes
-{
+parser_goto(const cbl_refer_t &value_ref,
+ size_t narg,
+ cbl_label_t * const labels[] )
+ {
// This is part of the Terrible Trio of parser_perform, parser_goto and
// parser_enter_[procedure]. parser_goto has an easier time of it than
// the other two, because it just has to jump from here to the entry
point
@@ -2390,11 +2391,8 @@ parser_goto( cbl_refer_t value_ref, size_t narg,
cbl_label_t * const labels[] )
{
// We will implement the two or more fanout with a switch statement.
- tree value = gg_define_int();
- get_binary_value( value,
- NULL,
- value_ref.field,
- refer_offset(value_ref));
+ tree value;
+ get_binary_value(value, value_ref, INT);
// value is properly 1 through nargs
@@ -2439,7 +2437,7 @@ parser_goto( cbl_refer_t value_ref, size_t narg,
cbl_label_t * const labels[] )
}
void
-parser_perform_times( cbl_label_t *proc_1, cbl_refer_t count )
+parser_perform_times( cbl_label_t *proc_1, const cbl_refer_t &count )
{
Analyze();
SHOW_PARSE
@@ -2451,7 +2449,8 @@ parser_perform_times( cbl_label_t *proc_1,
cbl_refer_t count )
char ach[32];
sprintf(ach, " proc_1 is at %p", static_cast<void*>(proc_1));
SHOW_PARSE_TEXT(ach)
- sprintf(ach, " proc_1->proc is %p",
static_cast<void*>(proc_1->structs.proc));
+ sprintf(ach, " proc_1->proc is %p",
+ static_cast<void*>(proc_1->structs.proc));
SHOW_PARSE_TEXT(ach)
SHOW_PARSE_END
}
@@ -2463,13 +2462,9 @@ parser_perform_times( cbl_label_t *proc_1,
cbl_refer_t count )
perform_is_armed = CURRENT_LINE_NUMBER ;
- tree counter = gg_define_variable(LONG);
-
// Get the count:
- get_binary_value( counter,
- NULL,
- count.field,
- refer_offset(count));
+ tree counter;
+ get_binary_value(counter, count, LONG);
// Make sure the initial count is valid:
WHILE( counter, gt_op, gg_cast(LONG, integer_zero_node) )
@@ -2588,7 +2583,7 @@ parser_perform(cbl_label_t *label, bool
suppress_nexting)
static void
internal_perform_through_times( cbl_label_t *proc_1,
cbl_label_t *proc_2,
- cbl_refer_t &count)
+ const cbl_refer_t &count)
{
Analyze();
SHOW_PARSE
@@ -2626,11 +2621,8 @@ internal_perform_through_times( cbl_label_t
*proc_1,
perform_is_armed = CURRENT_LINE_NUMBER ;
- tree counter = gg_define_variable(LONG);
- get_binary_value( counter,
- NULL,
- count.field,
- refer_offset(count));
+ tree counter;
+ get_binary_value(counter, count, LONG);
WHILE( counter, gt_op, gg_cast(LONG, integer_zero_node) )
{
internal_perform_through(proc_1, proc_2, true); // true means
suppress_nexting
@@ -4608,7 +4600,7 @@ parser_display_literal(const char *literal, bool
advance)
void
parser_display_internal(tree file_descriptor,
- cbl_refer_t refer,
+ const cbl_refer_t &refer,
bool advance)
{
Analyze();
@@ -5632,11 +5624,8 @@ program_end_stuff(cbl_refer_t refer,
{
// The field_type has a PICTURE string, so we need to convert
from the
// COBOL form to little-endian binary:
- tree value = gg_define_int128();
- get_binary_value( value,
- NULL,
- returner,
- size_t_zero_node);
+ tree value;
+ get_binary_value( value, returner, INT128);
gg_memcpy(gg_get_address_of(retval),
gg_get_address_of(value),
build_int_cst_type(SIZE_T, nbytes));
@@ -7210,11 +7199,8 @@ parser_relop_long(cbl_field_t *tgt,
}
tree tree_a = build_int_cst_type(LONG, avalue);
- tree tree_b = gg_define_variable(LONG);
- get_binary_value( tree_b,
- NULL,
- bref.field,
- refer_offset(bref) );
+ tree tree_b;
+ get_binary_value( tree_b, bref.field, LONG);
tree comp_res = gg_define_variable(LONG);
gg_assign(comp_res, gg_subtract(tree_a, tree_b));
@@ -7327,15 +7313,11 @@ parser_see_stop_run(struct cbl_refer_t
exit_status,
}
// It's a stop run. Return return-code to the operating system:
- tree returned_value = gg_define_variable(INT);
-
+ tree returned_value;
if( exit_status.field )
{
// There is an exit_status, so it wins:
- get_binary_value( returned_value,
- NULL,
- exit_status.field,
- refer_offset(exit_status));
+ get_binary_value( returned_value, exit_status.field, INT);
TRACE1
{
TRACE1_REFER(" exit_status ", exit_status, "")
@@ -7343,6 +7325,7 @@ parser_see_stop_run(struct cbl_refer_t exit_status,
}
else
{
+ returned_value = gg_define_variable(INT);
gg_assign(returned_value, gg_cast(INT,
current_function->var_decl_return));
TRACE1
{
@@ -7568,7 +7551,7 @@ parser_classify( cbl_field_t *tgt,
}
void
-parser_perform(const cbl_perform_tgt_t *tgt, cbl_refer_t how_many)
+parser_perform(const cbl_perform_tgt_t *tgt, const cbl_refer_t &how_many)
{
const cbl_field_t *N = how_many.field;
// No SHOW_PARSE here; we want to fall through:
@@ -8692,11 +8675,8 @@ parser_perform_inline_times(struct
cbl_perform_tgt_t *tgt,
}
gcc_assert(tgt);
- cbl_field_t *count = how_many.field;
- CHECK_FIELD(count);
- // This has to be on the stack, because performs can be nested
- tree counter = gg_define_variable(LONG);
+ tree counter = gg_define_variable(LONG);
/*
GOTO SETUP
@@ -8764,10 +8744,9 @@ parser_perform_inline_times(struct
cbl_perform_tgt_t *tgt,
SHOW_PARSE_END
}
- get_binary_value( counter,
- NULL,
- count,
- refer_offset(how_many));
+ tree initial_value;
+ get_binary_value(initial_value, how_many, LONG);
+ gg_assign(counter, initial_value);
SHOW_PARSE
{
@@ -9430,11 +9409,8 @@ parser_file_write( cbl_file_t *file,
tree t_advance = gg_define_variable(INT);
if(advance.field)
{
- tree value = gg_define_variable(INT);
- get_binary_value( value,
- NULL,
- advance.field,
- refer_offset(advance));
+ tree value;
+ get_binary_value( value, advance, INT);
gg_assign(t_advance, gg_cast(INT, value));
}
else
@@ -9741,7 +9717,7 @@ void
parser_file_start(struct cbl_file_t *file,
relop_t op,
int flk,
- cbl_refer_t length_ref )
+ const cbl_refer_t &length_ref )
{
Analyze();
SHOW_PARSE
@@ -9797,13 +9773,12 @@ parser_file_start(struct cbl_file_t *file,
flk = -1;
}
- tree length = gg_define_variable(SIZE_T);
- gg_assign(length, size_t_zero_node);
+ tree length = size_t_zero_node;
if( flk > 0 && !length_ref.field )
{
- // We need a length, and we don't have one. We have to calculate the
length
- // from the lengths of the fields that make up the specified key.
+ // We need a length, and we don't have one. We have to calculate the
+ // length from the lengths of the fields that make up the specified
key.
size_t combined_length = 0;
@@ -9818,14 +9793,11 @@ parser_file_start(struct cbl_file_t *file,
cbl_field_t *field = cbl_field_of(symbol_at(nfield));
combined_length += field->data.capacity();
}
- gg_assign(length, build_int_cst_type(SIZE_T, combined_length));
+ length = build_int_cst_type(SIZE_T, combined_length);
}
else if( flk > 0 )
{
- get_binary_value( length,
- NULL,
- length_ref.field,
- refer_offset(length_ref));
+ get_binary_value( length, length_ref, SIZE_T);
}
sv_is_i_o = true;
@@ -10820,7 +10792,7 @@ handle_gg_trim(cbl_field_t *tgt,
(arg.field->attr &
FIGCONST_MASK);
if( figconst )
{
- cbl_char_t figcst = charmap->figconst_character(figconst);
+ uint8_t figcst = charmap->figconst_character(figconst);
tree tfigcst = build_int_cst_type(UCHAR, figcst);
gg_assign(gg_indirect(char_p), tfigcst);
}
@@ -10878,7 +10850,7 @@ parser_trim( cbl_field_t *tgt,
(arg.field->attr &
FIGCONST_MASK);
if( figconst )
{
- cbl_char_t figcst = charmap->figconst_character(figconst);
+ uint8_t figcst = charmap->figconst_character(figconst);
tree tfigcst = build_int_cst_type(ULONG, figcst);
gg_memcpy(char_p,
@@ -11069,17 +11041,15 @@ parser_intrinsic_call_4( cbl_field_t *tgt,
static void
field_increment(cbl_field_t *fld )
{
- static tree value = gg_define_variable(INT128);
- static tree rdigits = gg_define_variable(INT);
-
- get_binary_value(value, rdigits, fld, size_t_zero_node);
- gg_assign( value,
- gg_add(value, gg_cast(SIZE_T, integer_one_node)));
+ // rdigits has to be zero.
+ tree value;
+ get_binary_value(value, fld, INT128);
+ gg_increment(value);
gg_call(VOID,
"__gg__int128_to_field",
gg_get_address_of(fld->var_decl_node),
- value,
- rdigits,
+ gg_cast(INT128, value),
+ integer_zero_node,
build_int_cst_type(INT, truncation_e),
null_pointer_node,
NULL_TREE );
@@ -11164,14 +11134,18 @@ parser_lsearch_start( cbl_label_t *name,
// Establish the initial value of our counter:
lsearch->counter = gg_define_variable(LONG);
- tree value = gg_define_int128();
+ tree value;
if(varying)
{
- get_binary_value(value, NULL, varying, size_t_zero_node);
+ get_binary_value(value, varying, SIZE_T);
}
else if( index )
{
- get_binary_value(value, NULL, index, size_t_zero_node);
+ get_binary_value(value, index, SIZE_T);
+ }
+ else
+ {
+ gcc_unreachable();
}
gg_assign(lsearch->counter, gg_cast(LONG, value));
@@ -11925,7 +11899,7 @@ parser_file_sort( cbl_file_t *workfile,
}
void
-parser_release( cbl_field_t *record_area )
+parser_release( const cbl_field_t *record_area )
{
Analyze();
SHOW_PARSE
@@ -13943,8 +13917,8 @@ parser_match_exception(cbl_field_t *index)
TRACE1
{
- tree index_val = gg_define_variable(INT);
- get_binary_value(index_val, NULL, index, size_t_zero_node);
+ tree index_val;
+ get_binary_value(index_val, index, INT);
TRACE1_INDENT
gg_printf("returned value is 0x%x (%d)", index_val, index_val,
NULL_TREE);
TRACE1_END
@@ -14683,7 +14657,9 @@ parser_local_add(struct cbl_field_t *new_var )
}
void
-parser_field_attr_set( cbl_field_t *tgt, cbl_field_attr_t attr, bool
on_off )
+parser_field_attr_set(const cbl_field_t *tgt,
+ cbl_field_attr_t attr,
+ bool on_off )
{
if( on_off )
{
diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h
index 00c234521fe..773edacb775 100644
--- a/gcc/cobol/genapi.h
+++ b/gcc/cobol/genapi.h
@@ -47,7 +47,7 @@ typedef struct TREEPLET
} TREEPLET;
void parser_display_internal( tree file_descriptor,
- cbl_refer_t refer,
+ const cbl_refer_t &refer,
bool advance=DISPLAY_NO_ADVANCE);
void parser_first_statement( int lineno );
@@ -236,7 +236,7 @@ void
parser_perform( struct cbl_label_t *label, bool suppress_nexting=false );
void
-parser_perform_times( struct cbl_label_t *label, cbl_refer_t count );
+parser_perform_times( struct cbl_label_t *label, const cbl_refer_t &count
);
void
parser_perform_start( struct cbl_perform_tgt_t *tgt );
@@ -253,7 +253,7 @@ parser_perform_conditional_end( struct
cbl_perform_tgt_t *tgt );
* For an in-line loop body, tgt->from.type == LblLoop, and tgt->to is
NULL.
*/
void
-parser_perform( const cbl_perform_tgt_t *tgt, cbl_refer_t N );
+parser_perform( const cbl_perform_tgt_t *tgt, const cbl_refer_t &N );
/*
* A simple UNTIL loop uses 1 varys element. For VARY loops, the
@@ -346,7 +346,7 @@ callback_t *
parser_label_addr( struct cbl_label_t *label );
void
-parser_goto( cbl_refer_t value, size_t narg, cbl_label_t * const labels[]
);
+parser_goto( const cbl_refer_t &value, size_t narg, cbl_label_t * const
labels[] );
void
parser_alter( cbl_perform_tgt_t *tgt );
@@ -357,8 +357,9 @@ void
parser_set_numeric(struct cbl_field_t *tgt, ssize_t value);
void
-parser_field_attr_set( cbl_field_t *tgt, cbl_field_attr_t attr, bool
on_off = true );
-
+parser_field_attr_set(const cbl_field_t *tgt,
+ cbl_field_attr_t attr,
+ bool on_off = true );
void
parser_file_add(struct cbl_file_t *file);
@@ -376,8 +377,10 @@ parser_file_read( struct cbl_file_t *file,
int where );
void
-parser_file_start( struct cbl_file_t *file, relop_t op, int flk,
- cbl_refer_t = cbl_refer_t() );
+parser_file_start( struct cbl_file_t *file,
+ relop_t op,
+ int flk,
+ const cbl_refer_t &length_ref = cbl_refer_t() );
/*
* Write *field* to *file*. *after* is a bool where false
@@ -466,7 +469,7 @@ parser_file_merge( cbl_file_t *file,
cbl_perform_tgt_t *out_proc );
void
-parser_release( cbl_field_t *record_area );
+parser_release( const cbl_field_t *record_area );
void
parser_exception_file( cbl_field_t *tgt, cbl_file_t* file = NULL );
diff --git a/gcc/cobol/gengen.cc b/gcc/cobol/gengen.cc
index 03f79c56692..9ddd296f0e3 100644
--- a/gcc/cobol/gengen.cc
+++ b/gcc/cobol/gengen.cc
@@ -398,6 +398,12 @@ gg_cast(tree type, tree var)
}
#endif
+ if( TREE_CODE(type) == INTEGER_TYPE
+ && TREE_CODE(TREE_TYPE(var)) == REAL_TYPE )
+ {
+ return gg_trunc(type, var);
+ }
+
return fold_convert(type, var);
}
@@ -534,10 +540,8 @@ gg_show_type(tree type)
tree
gg_assign(tree dest, const tree source)
{
- // This does the equivalent of a C/C++ "dest = source". When X1 is
set, it
- // does some checking for conditions that can result in inefficient
code, so
- // that is useful during development when even an astute programmer
might
- // need an assist with keeping variable types straight.
+ // This does the equivalent of a C/C++ "dest = source". It does some
+ // checking for conditions that can result in inefficient code.
// This routine also provides for the possibility that the assignment
is
// for a source that is a function invocation, as in
@@ -578,7 +582,7 @@ gg_assign(tree dest, const tree source)
// the same. This is a compilation-time error, since we want the
caller to
// have sorted the types out explicitly. If we don't throw an error
here,
// the gimple reduction will do so. Better to do it here, when we
know
- // where we are.S
+ // where we are.
static const int debugging = 1;
if( debugging )
{
diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc
index bdbfe8e691b..b3a89f9b899 100644
--- a/gcc/cobol/genmath.cc
+++ b/gcc/cobol/genmath.cc
@@ -392,7 +392,7 @@ largest_binary_term(size_t nA, const cbl_refer_t *A)
static bool
fast_add( size_t nC, cbl_num_result_t *C,
- size_t nA, cbl_refer_t *A,
+ size_t nA, const cbl_refer_t *A,
cbl_arith_format_t format,
const cbl_label_t *error,
const cbl_label_t *not_error)
@@ -426,29 +426,18 @@ fast_add( size_t nC, cbl_num_result_t *C,
// C, which is not how COBOL works.
tree A_value;
- if( refer_is_clean(A[0]) )
- {
- A_value = get_binary_value_tree(dest_type,
- NULL, // No rdigits
- A[0].field,
- integer_zero_node);
- }
- else
- {
- A_value = get_binary_value_tree(dest_type,
- NULL, // No rdigits
- A[0].field,
- refer_offset(A[0]));
- }
+ get_binary_value(A_value, A[0], dest_type);
+
if( refer_is_clean(C[0].refer) )
{
// We are accumulating into memory
- if(false && refer_is_working_storage(C[0].refer)
+ if(is_working_storage(C[0].refer)
&& C[0].refer.field->offset == 0 )
{
gg_assign( C[0].refer.field->data_decl_node,
-
gg_cast(TREE_TYPE(C[0].refer.field->data_decl_node), gg_add(
C[0].refer.field->data_decl_node, A_value)));
+
gg_cast(TREE_TYPE(C[0].refer.field->data_decl_node),
+ gg_add( C[0].refer.field->data_decl_node,
A_value)));
}
else
{
@@ -492,36 +481,10 @@ fast_add( size_t nC, cbl_num_result_t *C,
dest_addr = gg_cast(build_pointer_type(dest_type), dest_addr);
tree A_value;
- if( refer_is_clean(A[0]) )
- {
- A_value = get_binary_value_tree(dest_type,
- NULL, // No rdigits
- A[0].field,
- integer_zero_node);
- }
- else
- {
- A_value = get_binary_value_tree(dest_type,
- NULL, // No rdigits
- A[0].field,
- refer_offset(A[0]));
- }
+ get_binary_value(A_value, A[0], dest_type);
tree B_value;
- if( refer_is_clean(A[1]) )
- {
- B_value = get_binary_value_tree(dest_type,
- NULL, // No rdigits
- A[1].field,
- integer_zero_node);
- }
- else
- {
- B_value = get_binary_value_tree(dest_type,
- NULL, // No rdigits
- A[1].field,
- refer_offset(A[1]));
- }
+ get_binary_value(B_value, A[1], dest_type);
gg_assign( gg_indirect(dest_addr),
gg_add( A_value,
@@ -533,20 +496,14 @@ fast_add( size_t nC, cbl_num_result_t *C,
// We need to calculate the sum of all the A[] terms using
term_type as
// the intermediate type:
- tree sum = gg_define_variable(term_type);
- tree addend = gg_define_variable(term_type);
- get_binary_value( sum,
- NULL,
- A[0].field,
- refer_offset(A[0]));
+ tree sum ;
+ tree addend ;
+ get_binary_value(sum, A[0].field, term_type);
// Add in the rest of them:
for(size_t i=1; i<nA; i++)
{
- get_binary_value( addend,
- NULL,
- A[i].field,
- refer_offset(A[i]));
+ get_binary_value( addend, A[i].field, term_type);
gg_assign(sum, gg_add(sum, addend));
}
@@ -580,8 +537,8 @@ fast_add( size_t nC, cbl_num_result_t *C,
static bool
fast_subtract(size_t nC, cbl_num_result_t *C,
- size_t nA, cbl_refer_t *A,
- size_t nB, cbl_refer_t *B,
+ size_t nA, const cbl_refer_t *A,
+ size_t nB, const cbl_refer_t *B,
cbl_arith_format_t format,
const cbl_label_t *error,
const cbl_label_t *not_error)
@@ -633,20 +590,7 @@ fast_subtract(size_t nC, cbl_num_result_t *C,
// This is the simplest case of all. Just subtract A from C.
tree dest_type = tree_type_from_refer(C[0].refer);
tree A_value;
- if( refer_is_clean(A[0]) )
- {
- A_value = get_binary_value_tree(dest_type,
- NULL, // No rdigits
- A[0].field,
- integer_zero_node);
- }
- else
- {
- A_value = get_binary_value_tree(dest_type,
- NULL, // No rdigits
- A[0].field,
- refer_offset(A[0]));
- }
+ get_binary_value(A_value, A[0], dest_type);
if( format == giving_e )
{
// Make C = B - A
@@ -663,21 +607,7 @@ fast_subtract(size_t nC, cbl_num_result_t *C,
dest_addr = gg_cast(build_pointer_type(dest_type), dest_addr);
tree B_value;
- if( refer_is_clean(B[0]) )
- {
- B_value = get_binary_value_tree(dest_type,
- NULL, // No rdigits
- B[0].field,
- integer_zero_node);
- }
- else
- {
- B_value = get_binary_value_tree(dest_type,
- NULL, // No rdigits
- B[0].field,
- refer_offset(B[0]));
- }
-
+ get_binary_value(B_value, B[0], dest_type);
gg_assign( gg_indirect(dest_addr),
gg_cast(dest_type, gg_subtract( B_value,
A_value)));
@@ -713,14 +643,14 @@ fast_subtract(size_t nC, cbl_num_result_t *C,
// We need to calculate the sum of all the A[] terms using
term_type as
// the intermediate type:
- tree sum = gg_define_variable(term_type);
- tree addend = gg_define_variable(term_type);
- get_binary_value(sum, NULL, A[0].field, refer_offset(A[0]));
+ tree sum ;
+ tree addend ;
+ get_binary_value(sum, A[0].field, term_type);
// Add in the rest of them:
for(size_t i=1; i<nA; i++)
{
- get_binary_value(addend, NULL, A[i].field, refer_offset(A[i]));
+ get_binary_value(addend, A[i].field, term_type);
gg_assign(sum, gg_add(sum, addend));
}
//gg_printf("The intermediate sum is %ld\n", gg_cast(LONG, sum),
NULL_TREE);
@@ -728,7 +658,7 @@ fast_subtract(size_t nC, cbl_num_result_t *C,
if( format == giving_e )
{
// We now subtract the sum from B[0]
- get_binary_value(addend, NULL, B[0].field, refer_offset(B[0]));
+ get_binary_value(addend, B[0].field, term_type);
gg_assign(sum, gg_subtract(addend, sum));
}
@@ -762,8 +692,8 @@ fast_subtract(size_t nC, cbl_num_result_t *C,
static bool
fast_multiply(size_t nC, cbl_num_result_t *C,
- size_t nA, cbl_refer_t *A,
- size_t nB, cbl_refer_t *B)
+ size_t nA, const cbl_refer_t *A,
+ size_t nB, const cbl_refer_t *B)
{
bool retval = false;
if( all_results_integer(nC, C) )
@@ -794,14 +724,14 @@ fast_multiply(size_t nC, cbl_num_result_t *C,
{
// All the terms are things we can work with.
- tree valA = gg_define_variable(term_type);
- tree valB = gg_define_variable(term_type);
- get_binary_value(valA, NULL, A[0].field, refer_offset(A[0]));
+ tree valA ;
+ tree valB ;
+ get_binary_value(valA, A[0].field, term_type);
if( nB )
{
// This is a MULTIPLY Format 2
- get_binary_value(valB, NULL, B[0].field, refer_offset(B[0]));
+ get_binary_value(valB, B[0].field, term_type);
gg_assign(valA, gg_multiply(valA, valB));
}
@@ -834,8 +764,8 @@ fast_multiply(size_t nC, cbl_num_result_t *C,
static bool
fast_divide(size_t nC, cbl_num_result_t *C,
- size_t nA, cbl_refer_t *A,
- size_t nB, cbl_refer_t *B,
+ size_t nA, const cbl_refer_t *A,
+ size_t nB, const cbl_refer_t *B,
const cbl_refer_t &remainder)
{
bool retval = false;
@@ -867,16 +797,16 @@ fast_divide(size_t nC, cbl_num_result_t *C,
{
// All the terms are things we can work with.
- tree divisor = gg_define_variable(term_type);
- tree dividend = gg_define_variable(term_type);
+ tree divisor ;
+ tree dividend ;
tree quotient = NULL_TREE;
- get_binary_value(divisor, NULL, A[0].field, refer_offset(A[0]));
+ get_binary_value(divisor, A[0].field, term_type);
if( nB )
{
// This is a MULTIPLY Format 2, where we are dividing A into B
and
// assigning that to C
- get_binary_value(dividend, NULL, B[0].field, refer_offset(B[0]));
+ get_binary_value(dividend, B[0].field, term_type);
quotient = gg_define_variable(term_type);
// Yes, in this case the divisor and dividend are switched.
Things are
diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc
index 142e0bb02e2..e2b7f1c293b 100644
--- a/gcc/cobol/genutil.cc
+++ b/gcc/cobol/genutil.cc
@@ -41,6 +41,7 @@
#include "toplev.h"
#include "function.h"
#include "fold-const.h"
+#include "target.h"
#include "../../libgcobol/ec.h"
#include "../../libgcobol/common-defs.h"
#include "util.h"
@@ -120,7 +121,7 @@ tree var_decl_dialects; // void* __gg__dialects
#endif
int
-get_scaled_rdigits(cbl_field_t *field)
+get_scaled_rdigits(const cbl_field_t *field)
{
int retval;
if( !(field->attr & scaled_e) )
@@ -149,7 +150,7 @@ get_scaled_rdigits(cbl_field_t *field)
}
int
-get_scaled_digits(cbl_field_t *field)
+get_scaled_digits(const cbl_field_t *field)
{
int retval;
if( !(field->attr & scaled_e) )
@@ -178,15 +179,16 @@ get_scaled_digits(cbl_field_t *field)
return retval;
}
-void
-get_integer_value(tree value, // We know this is a LONG
- cbl_field_t *field,
- tree offset,
- bool check_for_fractional_digits)
+#define CHECK_FOR_FRACTIONAL_DIGITS true
+static void
+giv_helper(tree retval, // We know this is a variable for the returned
value.
+ const cbl_field_t *field,
+ tree value, // Comes in as INT128
+ bool check_for_fractional_digits)
{
if( field->type == FldLiteralN && field->data.rdigits==0 )
{
- gg_assign(value, gg_cast(LONG, field->data_decl_node));
+ gg_assign(retval, gg_cast(TREE_TYPE(retval), field->data_decl_node));
return;
}
@@ -198,32 +200,47 @@ get_integer_value(tree value, // We know this is a
LONG
// If the field_i has rdigits, and if any of those rdigits are
non-zero, we
// return a 1 so that our caller can decide what to do.
- tree temp = gg_define_variable(INT128);
tree rdigits = gg_define_variable(INT);
if( field->attr & intermediate_e )
{
- // Get the binary value, which for 99V99 can be 1234, meaning 12.34
- get_binary_value(temp, NULL, field, offset);
-
// Pick up the run-time number of rdigits:
gg_assign(rdigits, gg_cast(INT, member(field, "rdigits")));
// Scale by the number of rdigits, which turns 12.34 into 12.
// When check_for_fractional_digits is true, __gg__rdigits will be
set
// to 1 for 12.34, and will be set to zero 12.00
- scale_by_power_of_ten(temp,
+ scale_by_power_of_ten(value,
gg_negate(rdigits),
check_for_fractional_digits);
}
else
{
- get_binary_value(temp, rdigits, field, offset);
- scale_by_power_of_ten_N(temp,
+ scale_by_power_of_ten_N(value,
-get_scaled_rdigits(field),
check_for_fractional_digits);
}
- gg_assign(value, gg_cast(TREE_TYPE(value), temp));
+ gg_assign(retval, gg_cast(TREE_TYPE(retval), value));
+ }
+
+static void
+get_integer_value(tree retval,
+ const cbl_field_t *field,
+ bool check_for_fractional_digits = false)
+ {
+ tree value;
+ get_binary_value(value, field, INT128);
+ giv_helper(retval, field, value, check_for_fractional_digits);
+ }
+
+static void
+get_integer_value(tree retval,
+ const cbl_refer_t &refer,
+ bool check_for_fractional_digits = false)
+ {
+ tree value;
+ get_binary_value(value, refer, INT128);
+ giv_helper(retval, refer.field, value, check_for_fractional_digits);
}
static
@@ -270,8 +287,7 @@ get_and_check_refstart_and_reflen( tree
refstart,// LONG returned value
// disaster, disaster is what you get."
get_integer_value(refstart,
- refer.refmod.from->field,
- refer_offset(*refer.refmod.from));
+ *refer.refmod.from);
gg_decrement(refstart);
gg_assign(refstart, gg_multiply(refstart, stride));
@@ -279,8 +295,7 @@ get_and_check_refstart_and_reflen( tree
refstart,// LONG returned value
{
// The length was specified, so that's what we return:
get_integer_value(reflen,
- refer.refmod.len->field,
- refer_offset(*refer.refmod.len));
+ *refer.refmod.len);
// Modify refer.length by stride:
gg_assign(reflen, gg_multiply(reflen, stride));
}
@@ -298,8 +313,7 @@ get_and_check_refstart_and_reflen( tree
refstart,// LONG returned value
// ec_bound_ref_mode_e checking is enabled:
get_integer_value(refstart,
- refer.refmod.from->field,
- refer_offset(*refer.refmod.from),
+ *refer.refmod.from,
CHECK_FOR_FRACTIONAL_DIGITS);
IF( var_decl_rdigits,
@@ -344,8 +358,7 @@ get_and_check_refstart_and_reflen( tree
refstart,// LONG returned value
if( refer.refmod.len )
{
get_integer_value(reflen,
- refer.refmod.len->field,
- refer_offset(*refer.refmod.len),
+ *refer.refmod.len,
CHECK_FOR_FRACTIONAL_DIGITS);
gg_assign(reflen, gg_multiply(reflen, stride));
IF( var_decl_rdigits,
@@ -429,7 +442,7 @@ get_depending_on_value_from_odo(tree retval,
cbl_field_t *odo)
*/
const cbl_enabled_exceptions_t&
enabled_exceptions(
cdf_enabled_exceptions() );
- cbl_field_t *depending_on;
+ const cbl_field_t *depending_on;
depending_on = cbl_field_of(symbol_at(odo->occurs.depending_on));
if( !enabled_exceptions.match(ec_bound_odo_e) )
@@ -437,8 +450,7 @@ get_depending_on_value_from_odo(tree retval,
cbl_field_t *odo)
// With no exception testing, just pick up the value. If there is an
error
// the programmer will simply have to live with the consequences.
get_integer_value(retval,
- depending_on,
- NULL);
+ depending_on);
return;
}
@@ -446,7 +458,6 @@ get_depending_on_value_from_odo(tree retval,
cbl_field_t *odo)
// between the lower and upper OCCURS limits:
get_integer_value(retval,
depending_on,
- NULL,
CHECK_FOR_FRACTIONAL_DIGITS);
IF( var_decl_rdigits, ne_op, integer_zero_node )
@@ -669,14 +680,12 @@ get_data_offset(const cbl_refer_t &refer, int
*pflags = NULL)
{
// With no exception testing, just pick up the value
get_integer_value(subscript,
- refer.subscripts[i].field,
- refer_offset(refer.subscripts[i]));
+ refer.subscripts[i]);
}
else
{
get_integer_value(subscript,
- refer.subscripts[i].field,
- refer_offset(refer.subscripts[i]),
+ refer.subscripts[i],
CHECK_FOR_FRACTIONAL_DIGITS);
IF( var_decl_rdigits,
ne_op,
@@ -776,15 +785,6 @@ get_data_offset(const cbl_refer_t &refer, int *pflags
= NULL)
return retval;
}
-static tree
-digit(tree location, int offset, int stride)
- {
- return gg_bitwise_and(gg_indirect(location,
- build_int_cst_type(SIZE_T,
- offset*stride)),
- build_int_cst_type(UCHAR, 0x0F));
- }
-
static const unsigned long pots[20] =
{
1ULL, // 00
@@ -809,631 +809,6 @@ static const unsigned long pots[20] =
10000000000000000000ULL, // 19
};
-
-static tree
-num_disp_dive(tree location, // UCHAR_P to first digit
- int digits, //
- bool signable,
- int stride)
- {
- tree retval;
- tree type;
- if( digits <= 9 )
- {
- type = signable ? INT : UINT;
- }
- else if( digits < 19 )
- {
- type = signable ? LONG : ULONG;
- }
- else
- {
- type = signable ? INT128 : UINT128;
- }
- retval = gg_define_variable(type);
-
- switch(digits)
- {
- case 1:
- {
- gg_assign(retval, gg_cast(type, digit(location, 0, stride)));
- break;
- }
- case 2:
- {
- tree term_a = gg_multiply(gg_cast(type, digit(location, 0,
stride)),
- build_int_cst_type(type, 10));
- tree term_b = gg_cast(type, digit(location, 1, stride));
- gg_assign(retval,
- gg_add(term_a,
- term_b));
- break;
- }
- case 3:
- {
- tree term_a = gg_multiply(gg_cast(type, digit(location, 0,
stride)),
- build_int_cst_type(type, 100));
- tree term_b = gg_multiply(gg_cast(type, digit(location, 1,
stride)),
- build_int_cst_type(type, 10));
- tree term_c = gg_cast(type, digit(location, 2, stride));
- gg_assign(retval,
- gg_add(term_a,
- gg_add(term_b,
- term_c)));
- break;
- }
- case 4:
- {
- tree term_a = gg_multiply(gg_cast(type, digit(location, 0,
stride)),
- build_int_cst_type(type, 1000));
- tree term_b = gg_multiply(gg_cast(type, digit(location, 1,
stride)),
- build_int_cst_type(type, 100));
- tree term_c = gg_multiply(gg_cast(type, digit(location, 2,
stride)),
- build_int_cst_type(type, 10));
- tree term_d = gg_cast(type, digit(location, 3, stride));
- gg_assign(retval,
- gg_add(term_a,
- gg_add(term_b,
- gg_add(term_c,
- term_d))));
- break;
- }
- default:
- {
- // digits is between 5 and 38
- int nright = digits/2;
- int nleft = digits - nright;
-
- int64_t right_factor = pots[nright];
- tree term_a = gg_multiply(num_disp_dive(location,
- nleft,
- signable,
- stride),
- build_int_cst_type(type, right_factor));
- tree term_b = num_disp_dive(gg_add(location,
- build_int_cst_type(SIZE_T,
-
nleft*stride)),
- nright,
- signable,
- stride);
- gg_assign(retval, gg_add(term_a, term_b));
- break;
- }
- }
-
- return retval;
- }
-
-static tree
-pd_dive(tree location, int nbytes, bool signable)
- {
- tree type;
- int digits = nbytes * 2;
- if( digits < 10 )
- {
- type = signable ? INT : UINT;
- }
- else if(digits < 20 )
- {
- type = signable ? LONG : ULONG;
- }
- else
- {
- type = signable ? INT128 : UINT128;
- }
- tree retval = gg_define_variable(type);
-
- tree ten2 = build_int_cst_type(type, 100);
- tree ten4 = build_int_cst_type(type, 10000);
- tree ten6 = build_int_cst_type(type, 1000000);
-
- tree t1 = integer_one_node;
- tree t2 = build_int_cst_type(INT, 2);
- tree t3 = build_int_cst_type(INT, 3);
-
- switch(nbytes)
- {
- case 0:
- retval = integer_zero_node;
- break;
- case 1:
- gg_assign(retval,
- gg_cast(type,
- gg_array_value(var_decl_dp2bin,
- gg_indirect(location))));
- break;
- case 2:
- {
- tree A = gg_multiply(gg_cast(type,
- gg_array_value(var_decl_dp2bin,
-
gg_indirect(location))),
- ten2);
- tree B = gg_cast(type,
- gg_array_value(var_decl_dp2bin,
- gg_indirect(location, t1)));
- gg_assign(retval, gg_add(A, B));
- break;
- }
- case 3:
- {
- tree A = gg_multiply(gg_cast(type,
- gg_array_value(var_decl_dp2bin,
- gg_indirect(location))),
- ten4);
- tree B = gg_multiply(gg_cast(type,
- gg_array_value(var_decl_dp2bin,
- gg_indirect(location, t1))),
- ten2);
- tree C = gg_cast(type,
- gg_array_value(var_decl_dp2bin,
- gg_indirect(location, t2)));
- gg_assign(retval, gg_add(A, gg_add(B, C)));
- break;
- }
- case 4:
- {
- tree A = gg_multiply(gg_cast(type,
- gg_array_value(var_decl_dp2bin,
- gg_indirect(location))),
- ten6);
- tree B = gg_multiply(gg_cast(type,
- gg_array_value(var_decl_dp2bin,
- gg_indirect(location, t1))),
- ten4);
- tree C = gg_multiply(gg_cast(type,
- gg_array_value(var_decl_dp2bin,
- gg_indirect(location, t2))),
- ten2);
- tree D = gg_cast(type,
- gg_array_value(var_decl_dp2bin,
- gg_indirect(location, t3)));
- gg_assign(retval, gg_add(A, gg_add(B, gg_add(C, D))));
- break;
- }
- default:
- {
- int nright = nbytes/2;
- int nleft = nbytes - nright;
- tree A = gg_multiply( gg_cast(type, pd_dive(location, nleft,
signable)),
- build_int_cst_type(type, pots[nright*2]));
- tree B = gg_cast(type, pd_dive(gg_add(location,
- build_int_cst_type(SIZE_T,
nleft)),
- nright,
- signable));
- gg_assign(retval, gg_add(A, B));
- break;
- }
- }
-
- return retval;
- }
-
-static tree
-get_pd_value(tree return_type, cbl_field_t *field, tree location)
- {
- tree retval = gg_define_variable(return_type);
- bool has_sign_nybble = !(field->attr & separate_e);
- bool signable = !!(field->attr & signable_e);
- int nbytes = field->data.capacity();
-
- gg_assign(retval,
- gg_cast(return_type,
- pd_dive(location,
- has_sign_nybble ? nbytes - 1 : nbytes,
- signable)));
- if( has_sign_nybble )
- {
- gg_assign(retval,
- gg_add(gg_multiply(retval,
- build_int_cst_type(return_type, 10)),
- gg_cast(return_type,
- gg_rshift(gg_indirect(location,
- build_int_cst_type(SIZE_T,
nbytes-1)),
- build_int_cst_type(SIZE_T, 4)))));
-
- IF( gg_bitwise_and(gg_indirect(location, build_int_cst_type(SIZE_T,
nbytes-1)),
- build_int_cst_type(UCHAR, 0x0F)),
- eq_op,
- build_int_cst_type(UCHAR, 0x0D) )
- {
- gg_assign(retval, gg_negate(retval));
- }
- ELSE
- {
- }
- ENDIF
- }
-
- return retval;
- }
-
-tree
-get_binary_value_tree(tree return_type,
- tree rdigits,
- cbl_field_t *field,
- tree field_offset,
- tree hilo
- )
- {
- tree retval = gg_define_variable(return_type);
-
- if( hilo )
- {
- gg_assign(hilo, integer_zero_node);
- }
-
- bool needs_scaling = true;
- static const bool debugging=false;
-
- // Very special case:
- if( strcmp(field->name, "ZEROS") == 0 )
- {
- gg_assign(retval, gg_cast(return_type, integer_zero_node));
- if( rdigits )
- {
- gg_assign(rdigits, gg_cast(TREE_TYPE(rdigits), integer_zero_node));
- }
- return retval;
- }
-
- switch(field->type)
- {
- case FldLiteralN:
- {
- if( return_type == FLOAT )
- {
- cbl_internal_error("cannot get %<float%> value from %s",
field->name);
- }
- else
- {
- if( rdigits )
- {
- gg_assign(rdigits, build_int_cst_type(TREE_TYPE(rdigits),
- field->data.rdigits));
- }
- gg_assign(retval, gg_cast(return_type, field->data_decl_node));
- }
- break;
- }
-
- case FldNumericDisplay:
- {
- charmap_t *charmap = __gg__get_charmap(field->codeset.encoding);
- int stride = charmap->stride();
- // Establish the source
- tree source_location = gg_define_variable(UCHAR_P);
- gg_assign(source_location, get_data_address(field, field_offset));
- tree sign_location;
- if( (field->attr & signable_e)
- && (field->attr & leading_e)
- && (field->attr & separate_e) )
- {
- sign_location = gg_define_variable(UCHAR_P);
- gg_assign(sign_location, source_location);
- gg_assign(source_location,
- gg_add(source_location,
- build_int_cst_type(SIZE_T, stride)));
- }
- // source_location points to the first digit.
-
- tree dive_value = num_disp_dive(source_location,
- field->data.digits,
- !!(field->attr & signable_e),
- stride);
- gg_assign(retval, gg_cast(return_type, dive_value));
-
- // retval is the absolute value of the numeric-display string.
-
- if( field->attr & signable_e )
- {
- // Because the source is signable, we have to check if it is
flagged
- // as negative:
- if( (field->attr & leading_e)
- && (field->attr & separate_e) )
- {
- // We already know that sign_location is established
- }
- else if( !(field->attr & leading_e)
- && (field->attr & separate_e) )
- {
- sign_location = gg_define_variable(UCHAR_P);
- gg_assign(sign_location,
- gg_add(source_location,
- build_int_cst_type(SIZE_T,
-
field->data.digits*stride)));
- }
- else if( (field->attr & leading_e)
- && !(field->attr & separate_e) )
- {
- sign_location = gg_define_variable(UCHAR_P);
- gg_assign(sign_location, source_location);
- }
- else //if( !(field->attr & leading_e)
- // && !(field->attr & separate_e) )
- {
- sign_location = gg_define_variable(UCHAR_P);
- gg_assign(sign_location,
- gg_add(source_location,
- build_int_cst_type(SIZE_T,
-
(field->data.digits-1)*stride)));
- }
- if( field->attr & separate_e )
- {
- IF( gg_indirect(sign_location),
- eq_op,
- build_int_cst_type(UCHAR,
- charmap->mapped_character(ascii_minus))
)
- {
- gg_assign(retval, gg_negate(retval));
- }
- ELSE
- {
- }
- ENDIF
- }
- else
- {
- if( charmap->is_like_ebcdic() )
- {
- IF( gg_indirect(sign_location),
- lt_op,
- build_int_cst_type(UCHAR, 0xF0) )
- {
- // The digit is less than the EBCDIC '0'
- gg_assign(retval, gg_negate(retval));
- }
- ELSE
- {
- }
- ENDIF
- }
- else
- {
- IF( gg_indirect(sign_location),
- gt_op,
- build_int_cst_type(UCHAR, 0x39) )
- {
- // The digit is greater than the ASCII '9'
- gg_assign(retval, gg_negate(retval));
- }
- ELSE
- {
- }
- ENDIF
- }
- }
- }
- break;
- }
-
- case FldNumericBinary:
- {
- // As of this writing, the source value is big-endian
- // We have to convert it to a little-endian destination.
- tree value = gg_define_variable(return_type);
- tree dest = gg_cast(build_pointer_type(UCHAR),
gg_get_address_of(value));
- tree source = get_data_address(field, field_offset);
-
- size_t dest_nbytes =
TREE_INT_CST_LOW(TYPE_SIZE_UNIT(return_type));
- size_t source_nbytes = field->data.capacity();
-
- if( debugging )
- {
- gg_printf("dest_bytes/source_bytes %ld/%ld\n",
- build_int_cst_type(SIZE_T, dest_nbytes),
- build_int_cst_type(SIZE_T, source_nbytes),
- NULL_TREE);
- gg_printf("Starting value: ", NULL_TREE);
- hex_dump(source, source_nbytes);
- gg_printf("\n", NULL_TREE);
- }
-
- if( dest_nbytes <= source_nbytes )
- {
- // Destination is too small. We will move what we can, throwing
away
- // the most significant source bytes:
- for(size_t i=0; i<dest_nbytes; i++)
- {
- gg_assign(gg_array_value(dest, i),
- gg_array_value(source, source_nbytes-1-i) );
- }
- }
- else
- {
- // Destination is too big. We'll need to fill the high-order
bytes with
- // either 0x00 for positive numbers, or 0xFF for negative
- tree extension = gg_define_variable(UCHAR);
- if( field->attr & signable_e )
- {
- IF( gg_array_value(gg_cast(build_pointer_type(SCHAR), source)),
- lt_op,
- gg_cast(SCHAR, integer_zero_node) )
- {
- gg_assign(extension, build_int_cst_type(UCHAR, 0xFF));
- }
- ELSE
- {
- gg_assign(extension, build_int_cst_type(UCHAR, 0));
- }
- ENDIF
- }
- else
- {
- gg_assign(extension, build_int_cst_type(UCHAR, 0));
- }
-
- // Flip the source end-for-end and put it into the dest:
- size_t i=0;
- while(i < source_nbytes)
- {
- gg_assign(gg_array_value(dest, i),
- gg_array_value(source, source_nbytes-1-i) );
- i += 1;
- }
- // Fill the extra high-end bytes with 0x00 or 0xFF extension
-
- while(i < dest_nbytes)
- {
- gg_assign(gg_array_value(dest, i),
- extension);
- i += 1;
- }
- }
- if( debugging )
- {
- gg_printf("Ending value: ", NULL_TREE);
- hex_dump(dest, dest_nbytes);
- gg_printf("\n", NULL_TREE);
- }
- retval = value;
- break;
- }
-
- case FldNumericBin5:
- case FldIndex:
- case FldPointer:
- {
- if( field->attr & intermediate_e )
- {
- // It is a intermediate, so rdigits has to come from the run-time
structure
- if( rdigits )
- {
- gg_assign(rdigits,
- gg_cast( TREE_TYPE(rdigits),
- member(field, "rdigits")));
- }
- }
- else
- {
- // It isn't an intermediate, so we can safely use field->rdigits
- if( rdigits )
- {
- gg_assign(rdigits,
- build_int_cst_type( TREE_TYPE(rdigits),
- get_scaled_rdigits(field)));
- }
- }
- tree source_address = get_data_address(field, field_offset);
- tree source_type = tree_type_from_field(field);
- if( debugging && rdigits)
- {
- gg_printf("get_binary_value bin5 rdigits: %d\n", rdigits,
NULL_TREE);
- }
-
- retval = gg_cast(return_type,
- gg_indirect(gg_cast(
build_pointer_type(source_type),
- source_address )));
- break;
- }
-
- case FldPacked:
- {
- if( rdigits )
- {
- gg_assign(rdigits,
- build_int_cst_type( TREE_TYPE(rdigits),
- get_scaled_rdigits(field)));
- }
- gg_assign(retval,
- get_pd_value(return_type,
- field,
- get_data_address( field, field_offset)));
- break;
- }
-
- case FldFloat:
- {
- // We are going to assume that the float value contains an integer.
- if( rdigits )
- {
- gg_assign(rdigits,
- gg_cast( TREE_TYPE(rdigits), integer_zero_node));
- }
- tree value = gg_define_variable(return_type);
- gg_assign(value, gg_cast(return_type,
- gg_call_expr( INT128,
- "__gg__integer_from_float128",
-
gg_get_address_of(field->var_decl_node),
- NULL_TREE)));
- needs_scaling = false;
- retval = value;
- break;
- }
-
- default:
- {
- char *err = xasprintf("%s(): We know not how to"
- " get a binary value from %s\n",
- __func__,
- cbl_field_type_str(field->type) );
- cbl_internal_error("%s", err);
- abort();
- break;
- }
- }
-
- if( needs_scaling )
- {
- if( field->attr & scaled_e )
- {
- if( field->data.rdigits < 0 )
- {
- // Hey, Dubner!
- // Should that test be != 0 rather than < 0? Maybe not; this
routine
- // is supposed to be for integers.
- tree value = gg_define_variable(return_type);
- gg_assign(value, retval);
- scale_by_power_of_ten_N(value, -field->data.rdigits);
- retval = value;
- }
- }
- }
- return retval;
- }
-
-tree
-get_binary_value_tree(tree return_type,
- tree rdigits,
- const cbl_refer_t &refer,
- tree hilo
- )
- {
- tree retval;
- if( refer_is_clean(refer) )
- {
- retval = get_binary_value_tree(return_type,
- rdigits,
- refer.field,
- integer_zero_node,
- hilo);
- }
- else
- {
- retval = get_binary_value_tree(return_type,
- rdigits,
- refer.field,
- refer_offset(refer),
- hilo);
- }
- return retval;
- }
-
-void
-get_binary_value( tree value,
- tree rdigits,
- cbl_field_t *field,
- tree field_offset,
- tree hilo
- )
- {
- tree return_type = TREE_TYPE(value);
- gg_assign(value, get_binary_value_tree( return_type,
- rdigits,
- field,
- field_offset,
- hilo ));
- }
-
tree
tree_type_from_field(const cbl_field_t *field)
{
@@ -2061,6 +1436,20 @@ refer_is_clean(const cbl_refer_t &refer)
;
}
+
+bool
+field_is_super_clean(const cbl_field_t *field)
+ {
+ return // refer.field->type == FldLiteralA ||
+ field->type == FldLiteralN
+ || !(field->attr & ( based_e
+ | linkage_e
+ | local_e
+ | intermediate_e
+ | any_length_e
+ | external_e)) ;
+ }
+
bool
refer_is_super_clean(const cbl_refer_t &refer)
{
@@ -2085,28 +1474,35 @@ refer_is_super_clean(const cbl_refer_t &refer)
}
bool
-refer_is_working_storage(const cbl_refer_t &refer)
+is_working_storage(const cbl_field_t *field)
{
- // This returns TRUE in cases where the refer.field->data_decl_node is
+ // This returns TRUE in cases where the field->data_decl_node is
// stored in .bss or .data, and is thus directly addressable.
- bool retval = !( refer.field->attr & ( based_e
- | linkage_e
- | local_e
- | intermediate_e) )
- || (refer.field->type == FldLiteralN);
+ bool retval = !( field->attr & ( based_e
+ | linkage_e
+ | local_e
+ | intermediate_e) )
+ || (field->type == FldLiteralN);
return retval;
}
-/* This routine returns the length portion of a refmod(start:length)
reference.
- It extracts both the start and the length so that it can add them
together
- to make sure that result falls within refer.capacity.
+bool
+is_working_storage(const cbl_refer_t &refer)
+ {
+ // This returns TRUE in cases where the refer.field->data_decl_node is
+ return is_working_storage(refer.field);
+ }
- This routine shouldn't be called unless there is refmod involved.
- */
static
tree // size_t
refer_refmod_length(const cbl_refer_t &refer)
{
+ /* This routine returns the length portion of a refmod(start:length)
+ reference. It extracts both the start and the length so that it can
add
+ them together to make sure that result falls within refer.capacity.
+
+ This routine shouldn't be called unless there is refmod involved.
+ */
Analyze();
REFER("refstart and reflen");
tree refstart = gg_define_variable(LONG);
@@ -2353,142 +1749,87 @@ is_pure_integer(const cbl_field_t *field)
case FldGroup:
case FldNumericBinary:
case FldFloat:
- case FldPacked:
- case FldNumericDisplay:
- case FldNumericEdited:
- case FldAlphaEdited:
- case FldLiteralA:
- case FldClass:
- case FldConditional:
- case FldForward:
- case FldSwitch:
- case FldDisplay:
- break;
- }
- return retval;
- }
-
-static bool
-binary_from_FldNumericBin5(tree &value, const cbl_refer_t &refer, tree
type)
- {
- bool retval = false;
-
- tree source_type = tree_type_from_field(refer.field);
-
- if( refer_is_working_storage(refer) )
- {
- if( !type )
- {
- type = source_type;
- }
-
- value = gg_define_variable(type);
-
- if( refer.field->offset == 0
- && TREE_CODE(TREE_TYPE(refer.field->data_decl_node)) ==
INTEGER_TYPE)
- {
- // This is the cleanest method: We can just pick up the original
base
- // data.
-
-//#define FOUND_THE_ALIASING_PROBLEM
-#ifdef FOUND_THE_ALIASING_PROBLEM
- // At the present writing, we can't just pick up the data_decl_node
data,
- // because the contents can be altered by pointer operations that
the
- // compiler doesn't know about. And we get errors, first noted
with the
- // results of fast_add (which uses *(data *) to change the data.)
Using
- // -fno-strict-aliasing makes the problem go away. Until we get
that
- // sorted out, we use the slightly less efficient method on the
other
- // side of the #else.
- gg_assign(value, gg_cast(type, refer.field->data_decl_node));
-#else
- tree base;
- base =
gg_cast(build_pointer_type(TREE_TYPE(refer.field->data_decl_node)),
- member(refer.field->var_decl_node,
"data"));
- gg_assign(value,
- gg_cast(type,
-
gg_indirect(gg_cast(build_pointer_type(source_type),
- base))));
-#endif
- }
- else
- {
- // We can't just pick up the stuff at data_decl_node. Either there
is
- // an offset from the 01 grandfather, or else there is a type
mismatch,
- // probably because of a REDEFINES. So, we do the equivalent of
- // *(type *)&thing;
- tree base;
- base = gg_cast(UCHAR_P,
gg_get_address(refer.field->data_decl_node));
- if( refer_is_clean(refer) )
- {
- if( refer.field->offset )
- {
- base = gg_add(base, build_int_cst_type(SIZE_T,
refer.field->offset));
- }
- }
- else
- {
- base = gg_add(base, refer_offset(refer));
- }
- gg_assign(value,
- gg_cast(type,
-
gg_indirect(gg_cast(build_pointer_type(source_type),
- base))));
- }
- retval = true;
- }
- else
- {
- if( !type )
- {
- type = tree_type_from_field(refer.field);
- }
-
- tree base;
- get_location(base, refer);
- value = gg_define_variable(type);
- gg_assign(value,
- gg_cast(type,
-
gg_indirect(gg_cast(build_pointer_type(source_type),
- base))));
- retval = true;
+ case FldPacked:
+ case FldNumericDisplay:
+ case FldNumericEdited:
+ case FldAlphaEdited:
+ case FldLiteralA:
+ case FldClass:
+ case FldConditional:
+ case FldForward:
+ case FldSwitch:
+ case FldDisplay:
+ break;
}
return retval;
}
-static bool
-binary_from_FldLiteralN(tree &value, const cbl_refer_t &refer, tree type)
+static void
+binary_from_FldNumericBin5(tree &value, const cbl_field_t *field, tree
dest_type)
{
- // The data_decl_node has the value we need.
+ value = gg_define_variable(dest_type);
+ safe_cast(value, field);
+ }
- tree source_type = tree_type_from_field(refer.field);
- if( !type )
- {
- type = source_type;
- }
+static void
+binary_from_FldNumericBin5(tree &value, const cbl_refer_t &refer, tree
dest_type)
+ {
+ value = gg_define_variable(dest_type);
+ safe_cast(value, refer);
+ }
- value = gg_define_variable(type);
- gg_assign(value, gg_cast(type, refer.field->data_decl_node));
+static void
+binary_from_FldLiteralN(tree &value, const cbl_field_t *field, tree
dest_type)
+ {
+ // The data_decl_node has the value we need.
+ value = gg_define_variable(dest_type);
+ gg_assign(value, gg_cast(dest_type, field->data_decl_node));
+ }
- return true;
+static void
+binary_from_FldLiteralN(tree &value, const cbl_refer_t &refer, tree type)
+ {
+ binary_from_FldLiteralN(value, refer.field, type);
}
+static void
+binary_from_FldNumericBinary(tree &value, const cbl_field_t *field, tree
type)
+ {
+ tree unflipped;
+ binary_from_FldNumericBin5(unflipped,
+ field,
+ tree_type_from_field(field));
+ // retval is in the machine's native encoding.
+ value = gg_define_variable(type);
+ if(!BYTES_BIG_ENDIAN)
+ {
+ // The actual return value gets the flipped bytes:
+ gg_assign(value, gg_cast(type, gg_bswap(unflipped)));
+ }
+ else
+ {
+ gg_assign(value, gg_cast(type, unflipped));
+ }
+ }
-bool
+static void
binary_from_FldNumericBinary(tree &value, const cbl_refer_t &refer, tree
type)
{
- bool retval = false;
-
- // get the value as its own type.
tree unflipped;
- retval = binary_from_FldNumericBin5(unflipped, refer, NULL_TREE);
- if( retval )
+ binary_from_FldNumericBin5(unflipped,
+ refer,
+ tree_type_from_field(refer.field));
+ // retval is in the machine's native encoding.
+ value = gg_define_variable(type);
+ if(!BYTES_BIG_ENDIAN)
{
// The actual return value gets the flipped bytes:
- value = gg_define_variable(type);
gg_assign(value, gg_cast(type, gg_bswap(unflipped)));
}
-
- return retval;
+ else
+ {
+ gg_assign(value, gg_cast(type, unflipped));
+ }
}
static void
@@ -2651,30 +1992,17 @@ d_and_q_num_disp( tree &retval, // We define
this return value
}
}
-bool
-binary_from_FldNumericDisplay(tree &value,
- const cbl_refer_t &refer,
- tree return_type)
+static void
+binary_from_numdisp(tree &value,
+ const cbl_field_t *field,
+ tree location,
+ tree return_type)
{
- // A return of false means we couldn't convert this value
- bool retval = false;
-
- tree source_type = tree_type_from_field(refer.field);
- if( !return_type )
- {
- return_type = source_type;
- }
-
// This is where we build the actual numeric value of the digits of the
// COBOL numeric display variable. It is up to the caller to interpret
// scaledness and rdigits and so forth.
value = gg_define_variable(return_type);
- // This is our address pointer, used for walking the digits.
- tree base = gg_define_variable(UCHAR_P);
-
- // This is the location of the byte holding the sign (if any)
- tree sign_location = gg_define_variable(UCHAR_P);
// This is the operational counter
tree digit_count = gg_define_variable(SIZE_T);
@@ -2683,78 +2011,71 @@ binary_from_FldNumericDisplay(tree &value,
// or 2 or 4 for utf16 and utf32.
tree stride;
- // This works for all forms of storage:
- gg_assign(base,
- gg_cast(build_pointer_type(UCHAR_P),
- member(refer.field->var_decl_node,"data")));
- if( !refer_is_clean(refer) )
- {
- gg_assign(base, gg_add(base, refer_offset(refer)));
- }
-
- gg_assign(digit_count, build_int_cst_type(SIZE_T,
refer.field->data.digits));
+ gg_assign(digit_count, build_int_cst_type(SIZE_T, field->data.digits));
- charmap_t *charmap = __gg__get_charmap(refer.field->codeset.encoding);
+ charmap_t *charmap = __gg__get_charmap(field->codeset.encoding);
size_t fstride = charmap->stride();
stride = build_int_cst_type(SIZE_T, fstride);
- if( refer.field->attr & signable_e )
+ tree sign_location = gg_define_variable(UCHAR_P);
+
+ if( field->attr & signable_e )
{
// The value is signable.
- if( refer.field->attr & separate_e )
+ if( field->attr & separate_e )
{
// The sign byte is separate from the digits
- if( refer.field->attr & leading_e )
+ if( field->attr & leading_e )
{
// separate & leading. sign_location is the first character.
- gg_assign(sign_location, base);
- gg_assign(base, gg_add(base, stride));
+ gg_assign(sign_location, location);
+ gg_assign(location, gg_add(location, stride));
}
else
{
// separate & trailing. The sign byte is after the last
character:
gg_assign(sign_location,
- gg_add(base,
+ gg_add(location,
build_int_cst_type(SIZE_T,
- refer.field->data.digits *
fstride)));
+ field->data.digits * fstride)));
}
}
else
{
// sign is internal:
- if( refer.field->attr & leading_e )
+ if( field->attr & leading_e )
{
// internal & leading
- gg_assign(sign_location, base);
+ gg_assign(sign_location, location);
}
else
{
// internal & trailing
gg_assign(sign_location,
- gg_add(base,
+ gg_add(location,
build_int_cst_type(SIZE_T,
fstride *
-
(refer.field->data.digits-1))));
+ (field->data.digits-1))));
}
}
}
- size_t digits = refer.field->data.digits;
+ size_t digits = field->data.digits;
// At this point, we have 'digits', which is the number of characters
at
- // 'base', The obvious thing is a multiply-and-accumulate loop, but
faster
- // code can result from allowing the middle-end to create overlapping.
+ // 'location', The obvious thing is a multiply-and-accumulate loop,
but
+ // faster code can result from allowing the middle-end to create
overlapping.
// This divide-and-conquer algorithm gives the middle-end that
flexibility.
// It runs about three times faster than a multiply-accumulate when
compiled
// with -O0, and about 2.8 times faster when compiled with -O2.
tree d_and_q;
- d_and_q_num_disp(d_and_q, base, digits, fstride);
+ d_and_q_num_disp(d_and_q, location, digits, fstride);
// d_and_q contains our value. We need to know if negativeness is
involved.
- if( refer.field->attr & signable_e )
+ if( field->attr & signable_e )
{
- if( refer.field->attr & separate_e )
+ if( field->attr & separate_e )
{
// If the sign location is a minus sign, we have to negate the
value.
IF( gg_indirect(sign_location),
@@ -2810,26 +2131,33 @@ binary_from_FldNumericDisplay(tree &value,
{
gg_assign(value, gg_cast(return_type, d_and_q));
}
+ }
- retval = true;
- return retval;
+static void
+binary_from_FldNumericDisplay(tree &value,
+ const cbl_field_t *field,
+ tree return_type)
+ {
+ tree location;
+ get_location(location, field);
+ binary_from_numdisp(value,
+ field,
+ location,
+ return_type);
}
- /* This is the GENERIC that creates
- static const unsigned char dp2bin[160] =
- {
- 00, 01, 02, 03, 04, 05, 06, 07, 8, 9, 0, 0, 0, 0, 0, 0, //
0x00
- 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 10, 10, 10, 10, 10, 10, //
0x10
- 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 20, 20, 20, 20, 20, 20, //
0x20
- 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 30, 30, 30, 30, 30, 30, //
0x30
- 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 40, 40, 40, 40, 40, 40, //
0x40
- 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 50, 50, 50, 50, 50, 50, //
0x50
- 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 60, 60, 60, 60, 60, 60, //
0x60
- 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 70, 70, 70, 70, 70, 70, //
0x70
- 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 80, 80, 80, 80, 80, 80, //
0x80
- 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 90, 90, 90, 90, 90, 90, //
0x90
- };
- */
+static void
+binary_from_FldNumericDisplay(tree &value,
+ const cbl_refer_t &refer,
+ tree return_type)
+ {
+ tree location;
+ get_location(location, refer);
+ binary_from_numdisp(value,
+ refer.field,
+ location,
+ return_type);
+ }
static tree
make_dp2bin_decl()
@@ -2995,46 +2323,29 @@ d_and_q_packed(tree &value, tree base, size_t
places)
}
}
-static bool
-binary_from_comp_3(tree &value, const cbl_refer_t &refer, tree type)
+static void
+b_from_c3(tree &value, const cbl_field_t *field, tree location, tree
type)
{
- bool retval = false;
-
// This is where we build the actual numeric value of the digits of the
// COBOL packed-decimal variable. It is up to the caller to interpret
// scaledness and rdigits and so forth.
- tree source_type = tree_type_from_field(refer.field);
-
- if( !type )
- {
- type = source_type;
- }
-
+ tree source_type = tree_type_from_field(field);
tree working = gg_define_variable(source_type);
- tree base = gg_define_variable(UCHAR_P);
- gg_assign(base,
- gg_cast(build_pointer_type(UCHAR_P),
- member(refer.field->var_decl_node,"data")));
- if( !refer_is_clean(refer) )
- {
- gg_assign(base, gg_add(base, refer_offset(refer)));
- }
-
// This is the location of the byte holding the sign nybble
tree sign_location = gg_define_variable(UCHAR_P);
// The sign nybble is in the last byte:
gg_assign(sign_location,
- gg_add(base,
+ gg_add(location,
build_int_cst_type(SIZE_T,
- refer.field->data.capacity()-1)));
+ field->data.capacity()-1)));
tree d_and_q;
// Pick up the binary value of the first capacity-1 places
d_and_q_packed(d_and_q,
- base,
- refer.field->data.capacity()-1);
+ location,
+ field->data.capacity()-1);
// Multiply that by 10
tree d_and_q_10 = gg_multiply(gg_cast(source_type, d_and_q),
build_int_cst_type(source_type, 10));
@@ -3057,85 +2368,166 @@ binary_from_comp_3(tree &value, const cbl_refer_t
&refer, tree type)
value = gg_define_variable(type);
gg_assign(value, gg_cast(type, working));
+ }
- retval = true;
- return retval;
+static void
+binary_from_comp_3(tree &value, const cbl_field_t *field, tree type)
+ {
+ tree location;
+ get_location(location, field);
+ b_from_c3(value, field, location, type);
}
-static bool
-binary_from_comp_6(tree &value, const cbl_refer_t &refer, tree type)
+static void
+binary_from_comp_3(tree &value, const cbl_refer_t &refer, tree type)
{
- bool retval = false;
+ tree location;
+ get_location(location, refer);
+ b_from_c3(value, refer.field, location, type);
+ }
+static void
+binary_from_comp_6(tree &value, const cbl_field_t *field, tree type)
+ {
// This is where we build the actual numeric value of the digits of the
// COBOL packed-decimal variable. It is up to the caller to interpret
// scaledness and rdigits and so forth.
value = gg_define_variable(type);
- tree base = gg_define_variable(UCHAR_P);
- gg_assign(base,
- gg_cast(build_pointer_type(UCHAR_P),
- member(refer.field->var_decl_node,"data")));
- if( !refer_is_clean(refer) )
- {
- gg_assign(base, gg_add(base, refer_offset(refer)));
- }
+ tree base;
+ get_location(base, field);
+ tree d_and_q;
+ d_and_q_packed(d_and_q,
+ base,
+ field->data.capacity());
+ gg_assign(value, gg_cast(type, d_and_q));
+ }
+static void
+binary_from_comp_6(tree &value, const cbl_refer_t &refer, tree type)
+ {
+ // This is where we build the actual numeric value of the digits of the
+ // COBOL packed-decimal variable. It is up to the caller to interpret
+ // scaledness and rdigits and so forth.
+ value = gg_define_variable(type);
+
+ tree base;
+ get_location(base, refer);
tree d_and_q;
d_and_q_packed(d_and_q,
base,
refer.field->data.capacity());
gg_assign(value, gg_cast(type, d_and_q));
+ }
- retval = true;
- return retval;
+static void
+binary_from_FldPacked(tree &value, const cbl_field_t *field, tree type)
+ {
+ if( field->attr & packed_no_sign_e )
+ {
+ binary_from_comp_6(value, field, type);
+ }
+ else
+ {
+ binary_from_comp_3(value, field, type);
+ }
}
-bool
+static void
binary_from_FldPacked(tree &value, const cbl_refer_t &refer, tree type)
{
- bool retval;
if( refer.field->attr & packed_no_sign_e )
{
- retval = binary_from_comp_6(value, refer, type);
+ binary_from_comp_6(value, refer, type);
}
else
{
- retval = binary_from_comp_3(value, refer, type);
+ binary_from_comp_3(value, refer, type);
}
- return retval;
}
-static
-bool binary_from_FldFloat(tree &value, const cbl_refer_t &refer, tree
type)
+static void
+binary_from_FldFloat(tree &value, const cbl_field_t *field, tree type)
{
- tree source_type = tree_type_from_field(refer.field);
+ value = gg_define_variable(type);
+ safe_cast(value, field);
+ }
+
+static void
+binary_from_FldFloat(tree &value, const cbl_refer_t &refer, tree type)
+ {
+ value = gg_define_variable(type);
+ safe_cast(value, refer);
+ }
+
+void
+get_binary_value(tree &value, const cbl_field_t *field, tree type)
+ {
+ /* There are other get binary value routines. This one is intended to
be the
+ "best in class" version, incorporating everything that's been
learned
+ about the process, and incorporating compiler SSA guidelines. */
- if( !type )
+ if( (field->attr & FIGCONST_MASK) == zero_value_e )
{
- type = source_type;
+ // The ZERO figurative constant is not flagged as signed:
+ if( !type )
+ {
+ type = UINT;
+ }
+ value = gg_define_variable(type);
+ gg_assign(value, gg_cast(type, integer_zero_node));
}
+ else
+ {
+ if( !type )
+ {
+ type = TREE_TYPE(value);
+ }
+ switch(field->type)
+ {
+ case FldLiteralN:
+ binary_from_FldLiteralN(value, field, type);
+ break;
- value = gg_define_variable(type);
+ case FldNumericBin5:
+ case FldIndex:
+ case FldPointer:
+ binary_from_FldNumericBin5(value, field, type);
+ break;
- tree base;
- get_location(base, refer);
+ case FldNumericBinary:
+ binary_from_FldNumericBinary(value, field, type);
+ break;
+
+ case FldNumericDisplay:
+ binary_from_FldNumericDisplay(value, field, type);
+ break;
+
+ case FldPacked:
+ binary_from_FldPacked(value, field, type);
+ break;
- gg_assign(value,
- gg_cast(type,
- gg_indirect(gg_cast(build_pointer_type(source_type),
-
base))));
+ case FldFloat:
+ binary_from_FldFloat(value, field, type);
+ break;
- return true;
+ default:
+ gcc_unreachable();
+ break;
+ }
+ }
}
-bool
+void
get_binary_value(tree &value, const cbl_refer_t &refer, tree type)
{
- bool retval = false;
/* There are other get binary value routines. This one is intended to
be the
"best in class" version, incorporating everything that's been
learned
- about the process, and incorporating compiler SSA guidelines. */
+ about the process, and incorporating compiler SSA guidelines.
+
+ On entry, value should be unassigned. It will be given the type
'type',
+ if present, and otherwise will be the same as the type derived from
the
+ source. */
if( (refer.field->attr & FIGCONST_MASK) == zero_value_e )
{
@@ -3146,10 +2538,13 @@ get_binary_value(tree &value, const cbl_refer_t
&refer, tree type)
}
value = gg_define_variable(type);
gg_assign(value, gg_cast(type, integer_zero_node));
- retval = true;
}
else if( refer.addr_of )
{
+ if( !type )
+ {
+ type = tree_type_from_field(refer.field);
+ }
// The case of ADDRESS OF
value = gg_define_variable(type);
tree base = gg_define_variable(UCHAR_P);
@@ -3162,33 +2557,36 @@ get_binary_value(tree &value, const cbl_refer_t
&refer, tree type)
}
else
{
- // We know that the refer is a type that involves an integer binary
value.
+ if( !type )
+ {
+ type = tree_type_from_field(refer.field);
+ }
switch(refer.field->type)
{
case FldLiteralN:
- retval = binary_from_FldLiteralN(value, refer, type);
+ binary_from_FldLiteralN(value, refer, type);
break;
case FldNumericBin5:
case FldIndex:
case FldPointer:
- retval = binary_from_FldNumericBin5(value, refer, type);
+ binary_from_FldNumericBin5(value, refer, type);
break;
case FldNumericBinary:
- retval = binary_from_FldNumericBinary(value, refer, type);
+ binary_from_FldNumericBinary(value, refer, type);
break;
case FldNumericDisplay:
- retval = binary_from_FldNumericDisplay(value, refer, type);
+ binary_from_FldNumericDisplay(value, refer, type);
break;
case FldPacked:
- retval = binary_from_FldPacked(value, refer, type);
+ binary_from_FldPacked(value, refer, type);
break;
case FldFloat:
- retval = binary_from_FldFloat(value, refer, type);
+ binary_from_FldFloat(value, refer, type);
break;
default:
@@ -3196,45 +2594,102 @@ get_binary_value(tree &value, const cbl_refer_t
&refer, tree type)
break;
}
}
- return retval;
}
void
-get_location(tree &retval, const cbl_refer_t &refer)
+get_location(tree &retval, const cbl_field_t *field)
{
- // This routine looks at a refer and returns a UCHAR_P pointer to the
data
- // of the object.
retval = gg_define_variable(UCHAR_P);
-
- if( refer_is_super_clean(refer) )
+ if( field_is_super_clean(field) )
{
- // Working storage, not external, no refmods or subscripts. That
means
- // we can work with the actual data item, and save a level of
indirection.
-
- if( refer.field->offset )
+ if( field->offset )
{
gg_assign(retval,
gg_add(gg_cast(UCHAR_P,
-
gg_get_address(refer.field->data_decl_node)),
- build_int_cst_type(SIZE_T, refer.field->offset)));
+ gg_get_address(field->data_decl_node)),
+ build_int_cst_type(SIZE_T, field->offset)));
}
else
{
gg_assign(retval, gg_cast(UCHAR_P,
-
gg_get_address(refer.field->data_decl_node)));
+ gg_get_address(field->data_decl_node)));
}
}
+ else
+ {
+ gg_assign(retval,
+ gg_add(member(field->var_decl_node,"data"),
+ build_int_cst_type(SIZE_T, field->offset)));
+ }
+ }
+
+void
+get_location(tree &retval, const cbl_refer_t &refer)
+ {
+ /* This routine looks at a refer and returns a UCHAR_P pointer to the
data
+ of the object. */
+
+ if( refer_is_super_clean(refer) )
+ {
+ // Working storage, not external, no refmods or subscripts. That
means
+ // we can work with the actual data item, and save a level of
indirection.
+ get_location(retval, refer.field);
+ }
else
{
// The variable is external, or intermediate_e, or there are
subscripts, or
// there are refmods. We use the run-time "data", and add the
run-time
// offset to it.
+ retval = gg_define_variable(UCHAR_P);
gg_assign(retval,
gg_add(member(refer.field->var_decl_node,"data"),
refer_offset(refer)));
}
}
+void
+safe_cast(tree &target, // A defined variable.
+ tree source_location, // A pointer, usually UCHAR_P.
+ tree source_type) // The variable type pointed to by
+ // source_location.
+ {
+ /* The construction here does the safe equivalent of
+
+ int target = *(int *)location.
+
+ It does this by copying through memcpy rather than dereferencing
+ source_location as a source_type pointer. This avoids creating a
typed
+ lvalue access to storage whose effective/dynamic type may not be
+ source_type, and so avoids strict-aliasing violations. */
+
+ tree source = gg_define_variable(source_type);
+ gg_memcpy(gg_get_address_of(source),
+ source_location,
+ build_int_cst_type(SIZE_T, gg_sizeof(source_type)));
+ gg_assign(target,
+ gg_cast(TREE_TYPE(target), source));
+ }
+
+void
+safe_cast(tree &target, // A defined variable.
+ const cbl_field_t *field)
+ {
+ tree source_type = tree_type_from_field(field);
+ tree source_location;
+ get_location(source_location, field);
+ safe_cast(target, source_location, source_type);
+ }
+
+void
+safe_cast(tree &target, // A defined variable.
+ const cbl_refer_t &refer)
+ {
+ tree source_type = tree_type_from_field(refer.field);
+ tree source_location;
+ get_location(source_location, refer);
+ safe_cast(target, source_location, source_type);
+ }
+
void
get_length(tree &retval, const cbl_refer_t &refer)
{
@@ -3405,15 +2860,16 @@ data_decl_type_for(cbl_field_t *field)
}
void
-attribute_bit_clear(struct cbl_field_t *var, cbl_field_attr_t bits)
+attribute_bit_clear(const struct cbl_field_t *var, cbl_field_attr_t bits)
{
gg_assign( member(var, "attr"),
gg_bitwise_and( member(var, "attr"),
- gg_bitwise_not( build_int_cst_type(SIZE_T,
bits) )));
+ gg_bitwise_not( build_int_cst_type(SIZE_T,
+
bits))));
}
tree
-attribute_bit_get(struct cbl_field_t *var, cbl_field_attr_t bits)
+attribute_bit_get(const struct cbl_field_t *var, cbl_field_attr_t bits)
{
tree retval = gg_bitwise_and( member(var, "attr"),
build_int_cst_type(SIZE_T, bits) );
@@ -3421,7 +2877,7 @@ attribute_bit_get(struct cbl_field_t *var,
cbl_field_attr_t bits)
}
void
-attribute_bit_set(struct cbl_field_t *var, cbl_field_attr_t bits)
+attribute_bit_set(const struct cbl_field_t *var, cbl_field_attr_t bits)
{
gg_assign( member(var, "attr"),
gg_bitwise_or(member(var, "attr"),
@@ -3728,7 +3184,7 @@ round_this_value( tree &value,
ELSE {} ENDIF
break;
}
-
+
case toward_lesser_e:
{
/* "If the TOWARD-LESS phrase is specified, and the arithmetic
value
