diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h index 6bba662f206..b4761c3bf98 100644 --- a/gcc/cobol/genapi.h +++ b/gcc/cobol/genapi.h @@ -424,25 +424,19 @@ parser_lsearch_start( cbl_label_t *name, void parser_lsearch_conditional(cbl_label_t * name); void parser_bsearch_conditional(cbl_label_t * name); - void parser_lsearch_when( cbl_label_t *name, cbl_field_t *conditional ); -void -parser_bsearch_when(cbl_label_t *name, - cbl_refer_t key, - cbl_refer_t sarg, - bool ascending); - +void parser_bsearch_when( cbl_label_t *name, + const cbl_refer_t &key, + const cbl_refer_t &sarg, + bool ascending); void parser_lsearch_end( cbl_label_t *name ); void parser_bsearch_end( cbl_label_t *name ); +void parser_bsearch_start( cbl_label_t *name, cbl_field_t *tgt ); -void -parser_bsearch_start( cbl_label_t *name, cbl_field_t *tgt ); - -void -parser_sort(cbl_refer_t table, - bool duplicates, - cbl_alphabet_t *alphabet, - const std::vector& keys ); +void parser_sort( cbl_refer_t table, + bool duplicates, + cbl_alphabet_t *alphabet, + const std::vector& keys ); void parser_file_sort( cbl_file_t *file, bool duplicates, diff --git a/gcc/cobol/gengen.cc b/gcc/cobol/gengen.cc index c6936725f68..6a19ac6a2e1 100644 --- a/gcc/cobol/gengen.cc +++ b/gcc/cobol/gengen.cc @@ -370,25 +370,36 @@ gg_show_type(tree type) cbl_internal_error("The given type is NULL, and that is just not fair"); } + int code = TREE_CODE(type); + if( DECL_P(type) ) { type = TREE_TYPE(type); } - if( !TYPE_P(type) ) + if( !TYPE_P(type) && code != ARRAY_REF) { - cbl_internal_error("The given type is not a declaration or a TYPE"); + cbl_internal_error("%s", "The given type is not a declaration or a TYPE or an ARRAY_REF"); } static char ach[1100]; static char ach2[1024]; static char ach3[1024]; - switch( TREE_CODE(type) ) + switch( code ) { case POINTER_TYPE: strcpy(ach2, gg_show_type(TREE_TYPE(type))); sprintf(ach, "POINTER to %s", ach2); break; + case ARRAY_TYPE: + strcpy(ach2, gg_show_type(TREE_TYPE(type))); + sprintf(ach, "ARRAY"); + break; + + case ARRAY_REF: + sprintf(ach, "ARRAY_REF"); + break; + case VOID_TYPE: sprintf(ach, "VOID"); break; @@ -433,6 +444,11 @@ gg_show_type(tree type) strcat(ach, " readonly"); } + if( DECL_P(original_type) && TYPE_VOLATILE(original_type) ) + { + strcat(ach, " volatile"); + } + return ach; } @@ -852,7 +868,7 @@ gg_define_from_declaration(tree var_decl) // it's time to actually define the storage with a decl_expression: tree stmt = build1_loc (gg_token_location(), DECL_EXPR, - TREE_TYPE(var_decl), + void_type_node, var_decl); gg_append_statement(stmt); } @@ -911,6 +927,34 @@ gg_define_variable(tree type_decl, const char *name, gg_variable_scope_t vs_scop return var_decl; } +tree +gg_define_volatile_variable(tree type_decl, + const char *name, + gg_variable_scope_t vs_scope) + { + bool already_defined = false; + + tree volatile_type = build_qualified_type(type_decl, TYPE_QUAL_VOLATILE); + + tree var_decl = gg_declare_variable(volatile_type, + name, + NULL_TREE, + vs_scope, + &already_defined); + + /* Helpful, especially while debugging the front end. The volatile-qualified + type is the important part; these flags should agree with it. */ + TREE_THIS_VOLATILE(var_decl) = 1; + TREE_SIDE_EFFECTS(var_decl) = 1; + + if (!already_defined) + { + gg_define_from_declaration(var_decl); + } + + return var_decl; + } + tree gg_define_bool() { @@ -1316,6 +1360,23 @@ gg_pointer_to_array(tree expr) return build_fold_addr_expr (elem_ref); } +tree +gg_get_address(const tree var_decl) + { + /* This takes care of the problem of finding the address of a scalar, or of + an ARRAY_TYPE. I recommend using it carefully; there is something to be + said for knowing whether you are working with an array, or a scalar. */ + tree type = TREE_TYPE (var_decl); + if( TREE_CODE (type) == ARRAY_TYPE ) + { + return gg_pointer_to_array(var_decl); + } + + TREE_ADDRESSABLE(var_decl) = 1; + TREE_USED(var_decl) = 1; + return build_fold_addr_expr(var_decl); + } + tree gg_get_indirect_reference(tree pointer, tree offset) { @@ -1400,12 +1461,13 @@ gg_array_value(tree pointer, tree offset) } else { - return build4(ARRAY_REF, + tree retval = build4(ARRAY_REF, element_type, pointer, - offset, + fold_convert(SIZE_T, offset), NULL_TREE, NULL_TREE); + return retval; } } @@ -1594,6 +1656,62 @@ gg_bitwise_and(tree A, tree B) return build2( BIT_AND_EXPR, larger_type, gg_cast(larger_type,A), gg_cast(larger_type,B)); } +tree +gg_bswap (tree var) + { + location_t loc = UNKNOWN_LOCATION; + tree type = TREE_TYPE (var); + tree size = TYPE_SIZE_UNIT (type); + + gcc_assert (tree_fits_uhwi_p (size)); + + unsigned HOST_WIDE_INT size_in_bytes = tree_to_uhwi (size); + + enum built_in_function fncode; + tree unsigned_type; + + switch (size_in_bytes) + { + case 1: + return var; + + case 2: + fncode = BUILT_IN_BSWAP16; + unsigned_type = uint16_type_node; + break; + + case 4: + { + fncode = BUILT_IN_BSWAP32; + unsigned_type = uint32_type_node; + break; + } + + case 8: + fncode = BUILT_IN_BSWAP64; + unsigned_type = uint64_type_node; + break; + + case 16: + fncode = BUILT_IN_BSWAP128; + unsigned_type = unsigned_intTI_type_node; /* or your UINT128 type */ + break; + + default: + gcc_unreachable (); + } + + tree arg = fold_convert_loc (loc, unsigned_type, var); + + tree swapped = + build_call_expr_loc (loc, + builtin_decl_explicit (fncode), + 1, + arg); + + return fold_convert_loc (loc, type, swapped); + } + tree gg_build_relational_expression(tree operand_a, enum relop_t op, @@ -3126,6 +3244,19 @@ gg_free(tree pointer) gg_append_statement(the_call); } +tree +gg_memcmp(const tree s1, const tree s2, tree n) + { + tree the_call = + build_call_expr_loc(gg_token_location(), + builtin_decl_explicit (BUILT_IN_MEMCMP), + 3, + s1, + s2, + n); + return the_call; + } + void gg_record_statement_list_start() { diff --git a/gcc/cobol/gengen.h b/gcc/cobol/gengen.h index e961b27a82b..336bf2ef1d9 100644 --- a/gcc/cobol/gengen.h +++ b/gcc/cobol/gengen.h @@ -48,6 +48,7 @@ #define BOOL boolean_type_node #define CHAR char_type_node #define SCHAR signed_char_type_node +#define SCHAR_P build_pointer_type(SCHAR) #define UCHAR unsigned_char_type_node #define SHORT short_integer_type_node #define SHORT_P build_pointer_type(short_integer_type_node) @@ -266,6 +267,7 @@ struct gg_function_t tree entry_switch_goto; tree entry_switch_label; std::vector entry_goto_expressions; + bool alphabet_in_use; }; struct cbl_translation_unit_t @@ -363,6 +365,9 @@ extern tree gg_define_variable(tree type_decl, const char *name, gg_variable_scope_t vs_scope, tree initial_value); +extern tree gg_define_volatile_variable(tree type_decl, + const char *name, + gg_variable_scope_t vs_scope); // Utility definers: extern tree gg_define_bool(); extern tree gg_define_char(); @@ -414,9 +419,10 @@ extern tree gg_define_uchar_star(tree var); extern tree gg_define_uchar_star(const char *variable_name, tree var); // address_of operator; equivalent of C "&var_decl" -extern tree gg_get_address_of(const tree var_decl); +extern tree gg_get_address_of(const tree var_decl); // For scalars // equivalent of C "&array[0]" -extern tree gg_pointer_to_array(tree array); +extern tree gg_pointer_to_array(tree array); // For arrays +extern tree gg_get_address(const tree var_decl); // Array creation and access: @@ -434,6 +440,7 @@ extern void gg_decrement(tree var); extern tree gg_negate(tree var); // Two's complement negation extern tree gg_bitwise_not(tree var); // Bitwise inversion extern tree gg_abs(tree var); // Absolute value +extern tree gg_bswap(tree var); // end-for-end byte swap // And some binary operations: @@ -477,6 +484,7 @@ extern tree gg_read(tree fd, tree buf, tree count); extern void gg_write(tree fd, tree buf, tree count); extern void gg_memset(tree dest, const tree value, tree size); extern tree gg_memchr(tree s, tree c, tree n); +extern tree gg_memcmp(const tree dest, const tree src, tree size); extern void gg_memcpy(tree dest, const tree src, tree size); extern void gg_memmove(tree dest, const tree src, tree size); extern tree gg_memdup(tree data, tree length); @@ -580,4 +588,5 @@ extern void gg_insert_into_assemblerf(const char *format, ...) ATTRIBUTE_PRINTF_ extern char *gg_show_type(tree type); extern void gg_leaving_the_source_code_file(); + #endif diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc index 6eb87544ac0..7a39f87ab7a 100644 --- a/gcc/cobol/genmath.cc +++ b/gcc/cobol/genmath.cc @@ -93,7 +93,7 @@ set_up_arithmetic_error_handler(cbl_label_t *error, } static void -arithmetic_operation(size_t nC, cbl_num_result_t *C, +arithmetic_operation( size_t nC, cbl_num_result_t *C, size_t nA, cbl_refer_t *A, size_t nB, cbl_refer_t *B, cbl_arith_format_t format, @@ -140,21 +140,6 @@ arithmetic_operation(size_t nC, cbl_num_result_t *C, std::vector results(nC + 1); int ncount = 0; - if( nC+1 <= MIN_FIELD_BLOCK_SIZE ) - { - // We know there is room in our existing buffer - } - else - { - // We might have to allocate more space: - gg_call(VOID, - "__gg__resize_int_p", - gg_get_address_of(var_decl_arithmetic_rounds_size), - gg_get_address_of(var_decl_arithmetic_rounds), - build_int_cst_type(SIZE_T, nC+1), - NULL_TREE); - } - // We have to take into account the possibility the quotient of the division // can affect the disposition of the remainder. In particular, some of the // NIST tests have the construction @@ -182,10 +167,12 @@ arithmetic_operation(size_t nC, cbl_num_result_t *C, // list results[ncount++] = temp_remainder; } + tree array_of_int_type = build_array_type_nelts(INT, nC+1); + tree arithmetic_rounds = gg_define_variable(array_of_int_type); for(size_t i=0; idata.capacity(), - 0); + tree dest_type = tree_type_from_size(C[0].refer.field->data.capacity(), + 0); +// tree dest_type2 = TREE_TYPE(C[0].refer.field->data_decl_node); +// gcc_assert(dest_type2 == dest_type); + // All the numbers are integers without rdigits if( nC == 1 && nA == 1 @@ -449,13 +440,23 @@ fast_add( size_t nC, cbl_num_result_t *C, } if( refer_is_clean(C[0].refer) ) { - tree dest_addr = member(C[0].refer.field->var_decl_node, - "data"); - tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr); // We are accumulating into memory - gg_assign( gg_indirect(ptr), - gg_add( gg_indirect(ptr), - A_value)); + + if(false && refer_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))); + } + else + { + tree dest_addr = member(C[0].refer.field->var_decl_node, + "data"); + tree ptr = gg_cast(build_pointer_type(dest_type), dest_addr); + gg_assign( gg_indirect(ptr), + gg_add( gg_indirect(ptr), + A_value)); + } } else { @@ -1154,7 +1155,7 @@ parser_add( size_t nC, cbl_num_result_t *C, // Do phase 2, which puts the subtotal into each target location in turn for(size_t i=0; ioccurs.ntimes()) ) { @@ -825,8 +816,6 @@ get_data_offset(const cbl_refer_t &refer, return retval; } -//static tree tree_type_from_field(const cbl_field_t *field); - tree get_binary_value_tree(tree return_type, tree rdigits, @@ -856,9 +845,7 @@ get_binary_value_tree(tree return_type, return retval; } - static tree pointer = gg_define_variable( UCHAR_P, - "..gbv_pointer", - vs_file_static); + tree pointer = gg_define_variable(UCHAR_P); switch(field->type) { case FldLiteralN: @@ -874,10 +861,6 @@ get_binary_value_tree(tree return_type, gg_assign(rdigits, build_int_cst_type(TREE_TYPE(rdigits), field->data.rdigits)); } - // tree source_type = tree_type_from_field(field); - // retval = gg_cast(return_type, - // gg_indirect( gg_cast(build_pointer_type(source_type), - // gg_get_address_of(field->data_decl_node)))); retval = gg_cast(return_type, field->data_decl_node); } break; @@ -995,7 +978,7 @@ get_binary_value_tree(tree return_type, build_int_cst_type(INT, field->codeset.encoding), NULL_TREE)); // Assign the value we got from the string to our "return" value: - + // Note that cppcheck can't understand the run-time IF() // cppcheck-suppress redundantAssignment retval = gg_cast(return_type, val128); @@ -1244,14 +1227,169 @@ get_binary_value( tree value, hilo )); } -#if 0 -static tree +tree tree_type_from_field(const cbl_field_t *field) { - gcc_assert(field); - return tree_type_from_size(field->data.capacity(), field->attr & signable_e); + /* This routine is used to determine what action is taken with type of a + CALL ... USING and the matching PROCEDURE DIVISION USING of + a PROGRAM-ID or FUNCTION-ID + */ + tree retval; + + switch(field->type) + { + case FldGroup: + case FldAlphanumeric: + case FldAlphaEdited: + case FldNumericEdited: + case FldLiteralA: + { + retval = CHAR_P; + break; + } + + case FldNumericDisplay: + case FldPacked: + { + if( field->attr & signable_e ) + { + if( field->data.digits > 18 ) + { + retval = INT128; + } + else if( field->data.digits > 9) + { + retval = LONG; + } + else if( field->data.digits > 4) + { + retval = INT; + } + else if( field->data.digits > 2) + { + retval = SHORT; + } + else + { + retval = SCHAR; + } + } + else + { + if( field->data.digits > 18 ) + { + retval = UINT128; + } + else if( field->data.digits > 9) + { + retval = ULONG; + } + else if( field->data.digits > 4) + { + retval = UINT; + } + else if( field->data.digits > 2) + { + retval = USHORT; + } + else + { + retval = UCHAR; + } + } + break; + } + + case FldLiteralN: + case FldNumericBinary: + case FldNumericBin5: + case FldIndex: + case FldPointer: + { + if( field->attr & signable_e ) + { + if( field->data.capacity() == 16 ) + { + retval = INT128; + } + else if( field->data.capacity() == 8 ) + { + retval = LONG; + } + else if( field->data.capacity() == 4 ) + { + retval = INT; + } + else if( field->data.capacity() == 2 ) + { + retval = SHORT; + } + else if( field->data.capacity() == 1 ) + { + retval = SCHAR; + } + else + { + gcc_unreachable(); + } + } + else + { + if( field->data.capacity() == 16 ) + { + retval = UINT128; + } + else if( field->data.capacity() == 8 ) + { + retval = ULONG; + } + else if( field->data.capacity() == 4 ) + { + retval = UINT; + } + else if( field->data.capacity() == 2 ) + { + retval = USHORT; + } + else if( field->data.capacity() == 1 ) + { + retval = UCHAR; + } + else + { + gcc_unreachable(); + } + } + break; + } + + case FldFloat: + { + if( field->data.capacity() == 8 ) + { + retval = DOUBLE; + } + else if( field->data.capacity() == 4 ) + { + retval = FLOAT; + } + else + { + retval = FLOAT128; + } + break; + } + + default: + { + cbl_internal_error( "%s: Invalid field type %s:", + __func__, + cbl_field_type_str(field->type)); + break; + } + } + return retval; } -#endif tree get_data_address( cbl_field_t *field, @@ -1483,7 +1621,7 @@ hex_dump(tree data, size_t bytes) } tree -tree_type_from_size(size_t bytes, int signable) +tree_type_from_size(size_t bytes, uint64_t signable) { tree retval = NULL_TREE; @@ -1492,7 +1630,7 @@ tree_type_from_size(size_t bytes, int signable) switch( bytes ) { case 1: - retval = CHAR; + retval = SCHAR; break; case 2: retval = SHORT; @@ -1501,7 +1639,7 @@ tree_type_from_size(size_t bytes, int signable) retval = INT; break; case 8: - retval = LONGLONG; + retval = LONG; break; case 16: retval = INT128; @@ -1525,7 +1663,7 @@ tree_type_from_size(size_t bytes, int signable) retval = UINT; break; case 8: - retval = ULONGLONG; + retval = ULONG; break; case 16: retval = UINT128; @@ -1728,126 +1866,68 @@ copy_little_endian_into_place(cbl_field_t *dest, gg_cast(dest_type, value)); } -void -build_array_of_treeplets( int ngroup, - size_t N, +tree +build_array_of_referlets( size_t N, cbl_refer_t *refers) { - if( N ) + tree retval = null_pointer_node; + if(N) { - // At the present time the most this routine is called is four times, for - // the implementation of the UNSTRING verb. + // Create the array of referlets. + tree table_type = build_array_type_nelts(cblc_referlet_type_node, N); + tree reflets = gg_define_variable(table_type); - if( N > MIN_FIELD_BLOCK_SIZE ) - { - gg_call(VOID, - "__gg__resize_treeplet", - build_int_cst_type(INT, ngroup), - build_int_cst_type(SIZE_T, N), - NULL_TREE - ); - } - switch(ngroup) + // Initialize the array of referlets from the list of refers: + for(size_t i=0; ivar_decl_node) - : gg_cast(cblc_field_p_type_node, null_pointer_node)); - gg_assign(gg_array_value(var_decl_treeplet_1o, i), - refer_offset(refers[i])); - gg_assign(gg_array_value(var_decl_treeplet_1s, i), - refer_size_source(refers[i])); - } - break; - case 2: - for(size_t i=0; ivar_decl_node) - : gg_cast(cblc_field_p_type_node, null_pointer_node)); - gg_assign(gg_array_value(var_decl_treeplet_2o, i), - refer_offset(refers[i])); - gg_assign(gg_array_value(var_decl_treeplet_2s, i), - refer_size_source(refers[i])); - } - break; - case 3: - for(size_t i=0; ivar_decl_node) - : gg_cast(cblc_field_p_type_node, null_pointer_node)); - gg_assign(gg_array_value(var_decl_treeplet_3o, i), - refer_offset(refers[i])); - gg_assign(gg_array_value(var_decl_treeplet_3s, i), - refer_size_source(refers[i])); - } - break; - case 4: - for(size_t i=0; ivar_decl_node) - : gg_cast(cblc_field_p_type_node, null_pointer_node)); - gg_assign(gg_array_value(var_decl_treeplet_4o, i), - refer_offset(refers[i])); - gg_assign(gg_array_value(var_decl_treeplet_4s, i), - refer_size_source(refers[i])); - } - break; - default: - abort(); - break; + gg_assign(gg_struct_field_ref(gg_array_value(reflets, i), "field"), + refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node) + : gg_cast(cblc_field_p_type_node, + null_pointer_node)); + gg_assign(gg_struct_field_ref(gg_array_value(reflets, i), "offset"), + refer_offset(refers[i])); + gg_assign(gg_struct_field_ref(gg_array_value(reflets, i), "size"), + refer_size_source(refers[i])); } + + // And just return a pointer to the first element of the array: + retval = gg_pointer_to_array(reflets); } - else - { - // Just do nothing - } + + return retval; } -void -build_array_of_fourplets( int ngroup, - size_t N, - cbl_refer_t *refers) +tree +build_array_of_refers(size_t N, + cbl_refer_t *refers) { - int flag_bits = 0; + tree retval; if( N ) { - if( N > MIN_FIELD_BLOCK_SIZE ) - { - gg_call(VOID, - "__gg__resize_treeplet", - build_int_cst_type(INT, ngroup), - build_int_cst_type(SIZE_T, N), - NULL_TREE); - - gg_call(VOID, - "__gg__resize_int_p", - gg_get_address_of(var_decl_fourplet_flags_size), - gg_get_address_of(var_decl_fourplet_flags), - build_int_cst_type(SIZE_T, N), - NULL_TREE); - } - + int flag_bits = 0; + tree table_type = build_array_type_nelts(cblc_refer_type_node, N); + tree table = gg_define_variable(table_type); for(size_t i=0; ivar_decl_node)); - gg_assign(gg_array_value(var_decl_treeplet_1o, i), + gg_assign(gg_struct_field_ref(gg_array_value(table, i), "field"), + refers[i].field ? gg_get_address_of(refers[i].field->var_decl_node) + : gg_cast(cblc_field_p_type_node, + null_pointer_node)); + gg_assign(gg_struct_field_ref(gg_array_value(table, i), "offset"), refer_offset(refers[i], &flag_bits)); - gg_assign(gg_array_value(var_decl_treeplet_1s, i), + gg_assign(gg_struct_field_ref(gg_array_value(table, i), "size"), refer_size_source(refers[i])); - gg_assign(gg_array_value(var_decl_fourplet_flags, i), + gg_assign(gg_struct_field_ref(gg_array_value(table, i), "flags"), build_int_cst_type(INT, flag_bits)); } + // And just return a pointer to the first element of the array: + retval = gg_pointer_to_array(table); } else { abort(); } + return retval; } tree @@ -1910,7 +1990,7 @@ get_literal_string(cbl_field_t *field) bool refer_is_clean(const cbl_refer_t &refer) { - if( !refer.field || refer.field->is_numeric_constant() ) + if( !refer.field || refer.field->is_numeric_constant() ) { // It is routine for a refer to have no field. It happens when the parser // passes us a refer for an optional parameter that has been omitted, for @@ -1930,6 +2010,35 @@ refer_is_clean(const cbl_refer_t &refer) ; } +bool +refer_is_super_clean(const cbl_refer_t &refer) + { + // By super-clean, we mean that in addition to refer_is_clean, the value + // is also in working-storage with fixed offset and capacity, and is + // otherwise in condition so that we can use refer.field->var_data_node for + // GENERIC, thus getting rid the additional level of indirection through + // the refer.field->var_decl_node::data pointer + return refer_is_clean(refer) + && !(refer.field->attr & ( based_e + | linkage_e + | local_e + | intermediate_e + | any_length_e + | external_e)) ; + } + +bool +refer_is_working_storage(const cbl_refer_t &refer) + { + // This returns TRUE in cases where the refer.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); + 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 @@ -1983,8 +2092,7 @@ refer_fill_depends(const cbl_refer_t &refer) } tree // size_t -refer_offset(const cbl_refer_t &refer, - int *pflags) +refer_offset(const cbl_refer_t &refer, int *pflags) { // This routine calculates the effect of a refer offset on the // refer.field->data location. When there are subscripts, the data location @@ -2201,3 +2309,890 @@ is_pure_integer(const cbl_field_t *field) } return retval; } + +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; + } + return retval; + } + +bool +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 ) + { + // The actual return value gets the flipped bytes: + value = gg_define_variable(type); + gg_assign(value, gg_cast(type, gg_bswap(unflipped))); + } + + return retval; + } + +static const unsigned long pots[17] = + { + 1ULL, // 00 + 10ULL, // 01 + 100ULL, // 02 + 1000ULL, // 03 + 10000ULL, // 04 + 100000ULL, // 05 + 1000000ULL, // 06 + 10000000ULL, // 07 + 100000000ULL, // 08 + 1000000000ULL, // 09 + 10000000000ULL, // 10 + 100000000000ULL, // 11 + 1000000000000ULL, // 12 + 10000000000000ULL, // 13 + 100000000000000ULL, // 14 + 1000000000000000ULL, // 15 + 10000000000000000ULL, // 16 + }; + +static void +d_and_q_num_disp( tree &retval, // We define this return value + tree loc, // This is a UCHAR_P + size_t digits, + size_t stride) + { + switch( digits ) + { + case 1: + { + retval = gg_define_variable(UCHAR); + gg_assign(retval, + gg_bitwise_and(gg_indirect(loc), + build_int_cst_type(UCHAR, 0x0F))); + break; + } + + case 2: + { + retval = gg_define_variable(UCHAR); + tree ldigit = gg_bitwise_and(gg_indirect(loc), + build_int_cst_type(UCHAR, 0x0F)); + tree rdigit = gg_bitwise_and(gg_indirect(loc, + build_int_cst_type(SIZE_T, + stride)), + build_int_cst_type(UCHAR, 0x0F)); + gg_assign(retval, + gg_add(gg_multiply(ldigit, + build_int_cst_type(UCHAR, 10)), + rdigit)); + break; + } + + case 3: + case 4: + { + tree type = USHORT; + int rsize = 2; + retval = gg_define_variable(type); + tree left_half; + tree right_half; + d_and_q_num_disp(left_half, + loc, + digits - rsize, + stride); + d_and_q_num_disp(right_half, + gg_add(loc, + build_int_cst_type(SIZE_T, + stride*(digits - rsize))), + rsize, + stride); + gg_assign(retval, + gg_add(gg_cast(type, + gg_multiply(left_half, + build_int_cst_type(type, 100))), + gg_cast(type, right_half))); + break; + } + case 5: + case 6: + case 7: + case 8: + { + tree type = UINT; + int rsize = 4; + retval = gg_define_variable(type); + tree left_half; + tree right_half; + d_and_q_num_disp(left_half, + loc, + digits - rsize, + stride); + d_and_q_num_disp(right_half, + gg_add(loc, + build_int_cst_type(SIZE_T, + stride*(digits - rsize))), + rsize, + stride); + gg_assign(retval, + gg_add(gg_cast(type, + gg_multiply(left_half, + build_int_cst_type(type, 10000))), + gg_cast(type, right_half))); + break; + } + + case 9: + case 10: + case 11: + case 12: + case 13: + case 14: + case 15: + case 16: + { + tree type = ULONG; + int rsize = 8; + retval = gg_define_variable(type); + tree left_half; + tree right_half; + d_and_q_num_disp(left_half, + loc, + digits - rsize, + stride); + d_and_q_num_disp(right_half, + gg_add(loc, + build_int_cst_type(SIZE_T, + stride*(digits - rsize))), + rsize, + stride); + gg_assign(retval, + gg_add(gg_cast(type, + gg_multiply(left_half, + build_int_cst_type(type, 100000000UL))), + gg_cast(type, right_half))); + break; + } + + default: + { + // 'digits' is greater than 16. We will peel off sixteen digits at a + // time, and multiply-and-accumulate into our return value: + + tree type = UINT128; + retval = gg_define_variable(type); + + size_t digits_this_time = std::min(digits, 16UL); + digits -= digits_this_time; + tree value; + d_and_q_num_disp(value, + loc, + digits_this_time, + stride); + gg_assign(retval, gg_cast(type, value)); + gg_assign(loc, + gg_add(loc, + build_int_cst_type(SIZE_T, + stride*digits_this_time))); + while(digits > 0) + { + digits_this_time = std::min(digits, 16UL); + size_t pot = pots[digits_this_time]; + gg_assign(retval, gg_multiply(retval, + build_int_cst_type(type, pot))); + d_and_q_num_disp(value, + loc, + digits_this_time, + stride); + gg_assign(retval, gg_add(retval, gg_cast(type, value))); + gg_assign(loc, + gg_add(loc, + build_int_cst_type(SIZE_T, + stride*digits_this_time))); + digits -= digits_this_time; + } + break; + } + } + } + +bool +binary_from_FldNumericDisplay(tree &value, + const cbl_refer_t &refer, + 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); + + // The stride of the numerical value is the distance, in bytes, between + // characters of the zoned decimal value. It can be 1 (ascii or ebcdic), + // 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)); + + charmap_t *charmap = __gg__get_charmap(refer.field->codeset.encoding); + size_t fstride = charmap->stride(); + stride = build_int_cst_type(SIZE_T, fstride); + + if( refer.field->attr & signable_e ) + { + // The value is signable. + if( refer.field->attr & separate_e ) + { + // The sign byte is separate from the digits + if( refer.field->attr & leading_e ) + { + // separate & leading. sign_location is the first character. + gg_assign(sign_location, base); + gg_assign(base, gg_add(base, stride)); + } + else + { + // separate & trailing. The sign byte is after the last character: + gg_assign(sign_location, + gg_add(base, + build_int_cst_type(SIZE_T, + refer.field->data.digits * fstride))); + } + } + else + { + // sign is internal: + if( refer.field->attr & leading_e ) + { + // internal & leading + gg_assign(sign_location, base); + } + else + { + // internal & trailing + gg_assign(sign_location, + gg_add(base, + build_int_cst_type(SIZE_T, + fstride * + (refer.field->data.digits-1)))); + } + } + } + + size_t digits = refer.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. + + // 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 contains our value. We need to know if negativeness is involved. + if( refer.field->attr & signable_e ) + { + if( refer.field->attr & separate_e ) + { + // If the sign location is a minus sign, we have to negate the value. + IF( gg_indirect(sign_location), + eq_op, + build_int_cst_type(UCHAR, charmap->mapped_character(ascii_minus)) ) + { + gg_assign(value, gg_negate(gg_cast(return_type, d_and_q))); + } + ELSE + { + gg_assign(value, gg_cast(return_type, d_and_q)); + } + ENDIF + } + else + { + // The sign indicator is inside the sign_location digit. + if( charmap->is_like_ebcdic() ) + { + // In EBCDIC, the value is negative when the sign_indicator is less + // than ebcdic zero: + IF( gg_indirect(sign_location), + lt_op, + build_int_cst_type(UCHAR, charmap->mapped_character(ascii_zero)) ) + { + gg_assign(value, gg_negate(gg_cast(return_type, d_and_q))); + } + ELSE + { + gg_assign(value, gg_cast(return_type, d_and_q)); + } + ENDIF + } + else + { + // In ASCII, the value is negative when the sign_indicator is greater + // than ascii nine: + IF( gg_indirect(sign_location), + gt_op, + build_int_cst_type(UCHAR, ascii_9) ) + { + gg_assign(value, gg_negate(gg_cast(return_type, d_and_q))); + } + ELSE + { + gg_assign(value, gg_cast(return_type, d_and_q)); + } + ENDIF + } + } + } + else + { + gg_assign(value, gg_cast(return_type, d_and_q)); + } + + retval = true; + return retval; + } + + /* 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 tree +make_dp2bin_decl() + { + 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 + }; + + tree array_type = build_array_type_nelts(UCHAR, 160); + tree decl = gg_define_variable( array_type, + "_dp2bin", + vs_file_static); + tree ctor = make_node(CONSTRUCTOR); + TREE_TYPE(ctor) = array_type; + TREE_STATIC(ctor) = 1; + TREE_CONSTANT(ctor) = 1; + + for(int i=0; i<160; i++) + { + CONSTRUCTOR_APPEND_ELT( CONSTRUCTOR_ELTS(ctor), + build_int_cst_type(SIZE_T, i), + build_int_cst_type(UCHAR, dp2bin[i]) ); + } + DECL_INITIAL(decl) = ctor; + + TREE_STATIC (decl) = 1; + TREE_PUBLIC (decl) = 0; + DECL_EXTERNAL (decl) = 0; + TREE_READONLY (decl) = 1; + DECL_ARTIFICIAL (decl) = 1; + DECL_IGNORED_P (decl) = 1; + TREE_USED (decl) = 1; + + DECL_INITIAL (decl) = ctor; + + return decl; + } + +static void +d_and_q_packed(tree &value, tree base, size_t places) + { + static tree dp2bin = make_dp2bin_decl(); + + switch(places) + { + case 0: + { + // This is what happens for a single-digit comp-3 + tree type = UCHAR; + value = gg_define_variable(type); + gg_assign(value, gg_cast(type, integer_zero_node)); + break; + } + case 1: + { + // One place is two digits: + tree type = UCHAR; + value = gg_define_variable(type); + gg_assign(value, gg_array_value(dp2bin, gg_indirect(base))); + break; + } + case 2: + { + // Four digits: + tree type = USHORT; + value = gg_define_variable(type); + tree lhalf; + tree rhalf; + size_t rplaces = 1; + size_t lplaces = places - rplaces; + size_t pot = pots[rplaces*2]; + d_and_q_packed(lhalf, base, lplaces); + d_and_q_packed(rhalf, + gg_add(base, build_int_cst_type(SIZE_T, lplaces)), + rplaces); + gg_assign(value, + gg_add(gg_cast(type, gg_multiply(gg_cast(type, lhalf), + build_int_cst_type(type, pot))), + gg_cast(type, rhalf))); + break; + } + case 3: // six digits + case 4: // eight digits + { + tree type = UINT; + value = gg_define_variable(type); + tree lhalf; + tree rhalf; + size_t rplaces = 2; + size_t lplaces = places - rplaces; + size_t pot = pots[rplaces*2]; + d_and_q_packed(lhalf, base, lplaces); + d_and_q_packed(rhalf, + gg_add(base, build_int_cst_type(SIZE_T, lplaces)), + rplaces); + gg_assign(value, + gg_add(gg_cast(type, gg_multiply(gg_cast(type, lhalf), build_int_cst_type(type, pot))), + gg_cast(type, rhalf))); + break; + } + case 5: // ten digits + case 6: // twelve digits + case 7: // fourteen digits + case 8: // sixteen digits + { + tree type = ULONG; + value = gg_define_variable(type); + tree lhalf; + tree rhalf; + size_t rplaces = 4; + size_t lplaces = places - rplaces; + size_t pot = pots[rplaces*2]; + d_and_q_packed(lhalf, base, lplaces); + d_and_q_packed(rhalf, + gg_add(base, build_int_cst_type(SIZE_T, lplaces)), + rplaces); + gg_assign(value, + gg_add(gg_cast(type, gg_multiply(gg_cast(type, lhalf), build_int_cst_type(type, pot))), + gg_cast(type, rhalf))); + break; + } + default: + { + // This is nine places (eighteen digits) and up, We are going to peel + // off eight places (sixteen digits) at a time: + tree type = UINT128; + value = gg_define_variable(type); + tree lhalf; + size_t lplaces = places % 8; + if( lplaces != 0 ) + { + d_and_q_packed(lhalf, base, lplaces); + gg_assign(value, gg_cast(type, lhalf)); + places -= lplaces; + gg_assign(base, gg_add(base, build_int_cst_type(SIZE_T, lplaces))); + } + else + { + gg_assign(value, gg_cast(type, integer_zero_node)); + } + // The remaining places is a multiple of eight: + size_t pot = pots[8 * 2]; + while( places ) + { + gg_assign(value, gg_multiply(value, build_int_cst_type(type, pot))); + tree rhalf; + d_and_q_packed(rhalf, base, 8); + gg_assign(value, gg_add(value, gg_cast(type, rhalf))); + gg_assign(base, gg_add(base, build_int_cst_type(SIZE_T, 8))); + places -= 8; + } + } + } + } + +static bool +binary_from_comp_3(tree &value, const cbl_refer_t &refer, 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 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, + build_int_cst_type(SIZE_T, + refer.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); + // 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)); + // Pick up the final digit + tree final_digit = gg_rshift(gg_indirect(sign_location), + build_int_cst_type(SIZE_T, 4)); + // Add the results together. + tree x0f = build_int_cst_type(UCHAR, 0x0F); + tree x0d = build_int_cst_type(UCHAR, 0x0D); + IF( gg_bitwise_and( gg_indirect(sign_location), x0f), eq_op, x0d ) + { + gg_assign(working, + gg_cast(source_type, gg_negate(gg_add(d_and_q_10, final_digit)))); + } + ELSE + { + gg_assign(working, gg_cast(source_type, gg_add(d_and_q_10, final_digit))); + } + ENDIF + + value = gg_define_variable(type); + gg_assign(value, gg_cast(type, working)); + + retval = true; + return retval; + } + +static bool +binary_from_comp_6(tree &value, const cbl_refer_t &refer, 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. + 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 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; + } + +bool +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); + } + else + { + retval = binary_from_comp_3(value, refer, type); + } + return retval; + } + +static +bool binary_from_FldFloat(tree &value, const cbl_refer_t &refer, tree type) + { + tree source_type = tree_type_from_field(refer.field); + + if( !type ) + { + type = source_type; + } + + value = gg_define_variable(type); + + tree base; + get_location(base, refer); + + gg_assign(value, + gg_cast(type, + gg_indirect(gg_cast(build_pointer_type(source_type), + base)))); + + return true; + } + +bool +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. */ + + if( (refer.field->attr & FIGCONST_MASK) == zero_value_e ) + { + // 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)); + retval = true; + } + else if( refer.addr_of ) + { + // The case of ADDRESS OF + value = gg_define_variable(type); + tree base = gg_define_variable(UCHAR_P); + gg_assign(base, member(refer.field->var_decl_node, "data")); + if( !refer_is_clean(refer) ) + { + gg_assign(base, gg_add(base, refer_offset(refer))); + } + gg_assign(value, gg_cast(type, base)); + } + else + { + // We know that the refer is a type that involves an integer binary value. + switch(refer.field->type) + { + case FldNumericBin5: + case FldLiteralN: + case FldIndex: + case FldPointer: + retval = binary_from_FldNumericBin5(value, refer, type); + break; + + case FldNumericBinary: + retval = binary_from_FldNumericBinary(value, refer, type); + break; + + case FldNumericDisplay: + retval = binary_from_FldNumericDisplay(value, refer, type); + break; + + case FldPacked: + retval = binary_from_FldPacked(value, refer, type); + break; + + case FldFloat: + retval = binary_from_FldFloat(value, refer, type); + break; + + default: + gcc_unreachable(); + break; + } + } + return retval; + } + +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. + retval = gg_define_variable(UCHAR_P); + if( refer_is_super_clean(refer) ) + { + // Working storage, not external, no refmods or subscripts: + // gg_assign(retval, member(refer.field->var_decl_node,"data")); + tree base = gg_cast(UCHAR_P, + gg_get_address(refer.field->data_decl_node)); + if( refer.field->offset ) + { + tree offset = build_int_cst_type(SIZE_T, refer.field->offset); + gg_assign(retval, gg_cast(UCHAR_P, gg_add(base, offset))); + } + else + { + gg_assign(retval, base); + } + } + 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. + gg_assign(retval, + gg_add(member(refer.field->var_decl_node,"data"), + refer_offset(refer))); + } + } + +void +get_length(tree &retval, const cbl_refer_t &refer) + { + if(refer_is_clean(refer)) + { + if( refer.field->attr & any_length_e + || refer.field->attr & intermediate_e ) + { + // We need the run-time capacity. + retval = member(refer.field->var_decl_node, "capacity"); + } + else + { + // We can use the compile-time capacity. + retval = build_int_cst_type(SIZE_T, refer.field->data.capacity()); + } + } + else + { + retval = refer_size_source(refer); + } + } diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h index 002a524d00d..aeb99c23882 100644 --- a/gcc/cobol/genutil.h +++ b/gcc/cobol/genutil.h @@ -57,31 +57,14 @@ extern tree var_decl_call_parameter_signature; // char *__gg__call_parameter_s extern tree var_decl_call_parameter_count; // int __gg__call_parameter_count extern tree var_decl_call_parameter_lengths; // size_t *var_decl_call_parameter_lengths -extern tree var_decl_arithmetic_rounds_size; // size_t __gg__arithmetic_rounds_size; -extern tree var_decl_arithmetic_rounds; // int* __gg__arithmetic_rounds; -extern tree var_decl_fourplet_flags_size; // size_t __gg__fourplet_flags_size; -extern tree var_decl_fourplet_flags; // int* __gg__fourplet_flags; - -extern tree var_decl_treeplet_1f; // cblc_field_pp_type_node , "__gg__treeplet_1f" -extern tree var_decl_treeplet_1o; // SIZE_T_P , "__gg__treeplet_1o" -extern tree var_decl_treeplet_1s; // SIZE_T_P , "__gg__treeplet_1s" -extern tree var_decl_treeplet_2f; // cblc_field_pp_type_node , "__gg__treeplet_2f" -extern tree var_decl_treeplet_2o; // SIZE_T_P , "__gg__treeplet_2o" -extern tree var_decl_treeplet_2s; // SIZE_T_P , "__gg__treeplet_2s" -extern tree var_decl_treeplet_3f; // cblc_field_pp_type_node , "__gg__treeplet_3f" -extern tree var_decl_treeplet_3o; // SIZE_T_P , "__gg__treeplet_3o" -extern tree var_decl_treeplet_3s; // SIZE_T_P , "__gg__treeplet_3s" -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_index; // void* __gg__entry_index int get_scaled_rdigits(cbl_field_t *field); int get_scaled_digits(cbl_field_t *field); -tree tree_type_from_digits(size_t digits, int signable); -tree tree_type_from_size(size_t bytes, int signable); +tree tree_type_from_digits(size_t digits, uint64_t signable); +tree tree_type_from_size(size_t bytes, uint64_t signable); void get_binary_value( tree value, tree rdigits, @@ -138,24 +121,31 @@ void parser_display_internal_field(tree file_descriptor, char *get_literal_string(cbl_field_t *field); bool refer_is_clean(const cbl_refer_t &refer); +bool refer_is_super_clean(const cbl_refer_t &refer); +bool refer_is_working_storage(const cbl_refer_t &refer); -tree refer_offset(const cbl_refer_t &refer, - int *pflags=NULL); +tree refer_offset(const cbl_refer_t &refer, int *pflags=NULL); tree refer_size_source(const cbl_refer_t &refer); tree refer_size_dest(const cbl_refer_t &refer); tree qualified_data_location(const cbl_refer_t &refer); -void build_array_of_treeplets( int ngroup, - size_t N, +tree build_array_of_referlets( size_t N, cbl_refer_t *refers); -void build_array_of_fourplets( int ngroup, - size_t N, - cbl_refer_t *refers); +tree build_array_of_refers(size_t N, + cbl_refer_t *refers); void get_depending_on_value_from_odo(tree retval, cbl_field_t *odo); uint64_t get_time_nanoseconds(); bool is_pure_integer(const cbl_field_t *field); +tree tree_type_from_field(const cbl_field_t *field); + +bool get_binary_value(tree &value, + const cbl_refer_t &refer, + tree type = NULL_TREE); +void get_location(tree &retval, const cbl_refer_t &refer); +void get_length(tree &retval, const cbl_refer_t &refer); + #endif diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index c474f094803..dc2ac9765cd 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -1046,6 +1046,7 @@ class locale_tgt_t { %printer { fprintf(yyo, "%c %s", $$.invert? '!' : ' ', $$.term? name_of($$.term->field) : ""); } +%printer { fprintf(yyo, "%s", $$->dbgstr()); } %printer { fprintf(yyo, "%s (token %d)", keyword_str($$), $$ ); } relop %printer { fprintf(yyo, "'%s'", $$? $$ : "" ); } NAME @@ -6282,11 +6283,6 @@ exit_with: %empty * as specified in the rules." */ $$ = cbl_refer_t::empty(); - if( dialect_ibm() ) { - static auto rt = cbl_field_of(symbol_at(return_code_register())); - static cbl_refer_t status(rt); - $$ = &status; - } const auto prog = cbl_label_of(symbol_at(current_program_index())); if( prog->returning ) { $$ = new cbl_refer_t( cbl_field_of(symbol_at(prog->returning)) ); diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h index 6d33e557686..fd924e6938a 100644 --- a/gcc/cobol/parse_ante.h +++ b/gcc/cobol/parse_ante.h @@ -1591,7 +1591,9 @@ class log_expr_t { dbgmsg("%s:%d: logic error: %s is not a truth value", __func__, __LINE__, name_of(rhs)); } else { - parser_logop( andable, andable, and_op, rhs ); + auto cond = new_temporary(FldConditional); + parser_logop( cond, andable, and_op, rhs ); + andable = cond; } return this; } @@ -1604,7 +1606,9 @@ class log_expr_t { if( ! orable ) { orable = andable; } else { - parser_logop( orable, orable, or_op, andable ); + auto cond = new_temporary(FldConditional); + parser_logop( cond, orable, or_op, andable ); + orable = cond; } andable = rhs; return this; @@ -1612,7 +1616,9 @@ class log_expr_t { cbl_field_t * resolve() { assert(andable); if( orable ) { - parser_logop( andable, orable, or_op, andable ); + auto cond = new_temporary(FldConditional); + parser_logop( cond, orable, or_op, andable ); + andable = cond; orable = NULL; } assert(!orable); @@ -1621,6 +1627,19 @@ class log_expr_t { bool unresolved() const { return orable != NULL; } + + const char * dbgstr() const { + static char msg[64 * 2 + 16]; + int pos = 0; + if( andable ) { + pos = sprintf(msg, "%s", andable->name); + assert(0 < pos); + } + if( orable ) { + pos = sprintf(msg + pos, " or %s", orable->name); + } + return msg; + } }; static void ast_enter_section( cbl_label_t * ); diff --git a/gcc/cobol/scan_post.h b/gcc/cobol/scan_post.h index 71025a220e5..4806332bc55 100644 --- a/gcc/cobol/scan_post.h +++ b/gcc/cobol/scan_post.h @@ -410,4 +410,4 @@ yylex(void) { // tokens.h is generated as needed from parse.h with tokens.h.gen current_tokens_t::tokenset_t::tokenset_t() { #include "token_names.h" -}; +} diff --git a/gcc/cobol/structs.cc b/gcc/cobol/structs.cc index 16bd4e4df53..8f613da28d3 100644 --- a/gcc/cobol/structs.cc +++ b/gcc/cobol/structs.cc @@ -157,6 +157,8 @@ tree cblc_field_pp_type_node; tree cblc_file_type_node; tree cblc_file_p_type_node; tree cblc_goto_type_node; +tree cblc_referlet_type_node; +tree cblc_refer_type_node; // The following functions return type_decl nodes for the various structures @@ -213,7 +215,7 @@ create_cblc_file_t() // When doing FILE I/O, you need the cblc_file_t structure /* -typedef struct cblc_file_t* +typedef struct cblc_file_t { char *name; // This is the name of the structure; might be the name of an environment variable uint64_t symbol_index; // The symbol table index of the related cbl_file_t structure @@ -289,6 +291,46 @@ typedef struct cblc_file_t* return retval; } +static tree +create_referlet_t() + { + /* + typedef struct cblc_referlet_t + { + cblc_field_t *field; + size_t offset; + size_t size; + } cblc_referlet_t; + */ + tree retval = gg_get_structure_type_decl("cblc_referlet_t", + cblc_field_p_type_node, "field", + SIZE_T, "offset", + SIZE_T, "size", + NULL_TREE); + return retval; + } + +static tree +create_refer_t() + { + /* + typedef struct cblc_refer_t + { + cblc_field_t *field; + size_t offset; + size_t size; + int flags; + } cblc_refer_t; + */ + tree retval = gg_get_structure_type_decl("cblc_refer_t", + cblc_field_p_type_node, "field", + SIZE_T, "offset", + SIZE_T, "size", + INT, "flags", + NULL_TREE); + return retval; + } + void create_our_type_nodes() { @@ -301,6 +343,8 @@ create_our_type_nodes() cblc_field_pp_type_node = build_pointer_type(cblc_field_p_type_node); cblc_file_type_node = create_cblc_file_t(); cblc_file_p_type_node = build_pointer_type(cblc_file_type_node); + cblc_referlet_type_node = create_referlet_t(); + cblc_refer_type_node = create_refer_t(); } } diff --git a/gcc/cobol/structs.h b/gcc/cobol/structs.h index d26f13f7e1d..aefea7f26d6 100644 --- a/gcc/cobol/structs.h +++ b/gcc/cobol/structs.h @@ -45,6 +45,7 @@ extern void member(tree var, const char *member_name, int value); extern void member(tree var, const char *member_name, tree value); extern void member(cbl_field_t *var, const char *member_name, tree value); +extern void member2(tree var, const char *member_name, const char *submember, int value); extern void member2(tree var, const char *member_name, const char *submember, int value); extern void member2(tree var, const char *member_name, const char *submember, tree value); extern void member3(tree var, const char *mem, const char *sub1, const char *sub2, tree value); @@ -55,6 +56,8 @@ extern GTY(()) tree cblc_field_pp_type_node; extern GTY(()) tree cblc_file_type_node; extern GTY(()) tree cblc_file_p_type_node; extern GTY(()) tree cblc_goto_type_node; +extern GTY(()) tree cblc_referlet_type_node; +extern GTY(()) tree cblc_refer_type_node; extern void create_our_type_nodes(); diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index 46beb97f990..ade38eb227e 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -3782,7 +3782,7 @@ temporaries_t::add( cbl_field_t *field ) { bool yn(p.second); assert(yn); return *p.first; -}; +} cbl_field_t * temporaries_t::reuse( cbl_field_type_t type ) { diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h index d63d9a11149..f7fbc5ceccc 100644 --- a/gcc/cobol/symbols.h +++ b/gcc/cobol/symbols.h @@ -1364,7 +1364,6 @@ struct cbl_bsearch_t { tree right; // This is a long tree middle; // This is our copy of the index, so we only need to write // it and never read it. - tree compare_result; // This is an int, and avoids struct cbl_field_t *index; bool first_when; }; @@ -3114,15 +3113,9 @@ bool validate_numeric_edited(cbl_field_t *field); cbl_field_t *new_alphanumeric(const cbl_name_t name=nullptr, cbl_encoding_t encoding=no_encoding_e ); - // ENABLE_HIJACKING allows for code generation to be "hijacked" when the -// program-id is "dubner" or "hijack". See the mainline code in genapi.cc. - -// To enable hijacking, use -// -// make ... CPPFLAGS=-DENABLE_HIJACKING -// -// taking care to recaptulate whatever CPPFLAGS were set when configure was -// run. +// program-id is "dubner_h" or "hijack_h". See the mainline code in genapi.cc. + +#define ENABLE_HIJACKING #endif diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc index c6bffdfb68b..554c4fc5702 100644 --- a/gcc/cobol/util.cc +++ b/gcc/cobol/util.cc @@ -957,11 +957,9 @@ symbol_field_type_update( cbl_field_t *field, case FldSwitch: gcc_unreachable(); case FldAlphanumeric: - // MF allows PIC X(n) to have USAGE COMP-[5x] + // MF and GNU allow pic x usage comp-5. + // Dialect enforcement in that case is in field_binary_usage. if( candidate != FldNumericBin5 ) return false; - if( ! (dialect_mf() && field->has_attr(all_x_e)) ) { - return false; - } __attribute__((fallthrough)); case FldFloat: case FldNumericBin5: diff --git a/gcc/testsuite/cobol.dg/group2/Check_for_equality_of_COMP-1___COMP-2.cob b/gcc/testsuite/cobol.dg/group2/Check_for_equality_of_COMP-1___COMP-2.cob index 76bafa4b527..d4857134cfa 100644 --- a/gcc/testsuite/cobol.dg/group2/Check_for_equality_of_COMP-1___COMP-2.cob +++ b/gcc/testsuite/cobol.dg/group2/Check_for_equality_of_COMP-1___COMP-2.cob @@ -17,7 +17,7 @@ END-IF. MOVE SRC1 TO DST2. - IF DST1 not = 11.55 + IF DST2 not = 11.55 DISPLAY 'error: move/compare FLOAT-LONG to FLOAT-LONG failed ' DST2 END-DISPLAY END-IF. diff --git a/gcc/testsuite/cobol.dg/group2/ENTRY_statement.cob b/gcc/testsuite/cobol.dg/group2/ENTRY_statement.cob index f6186f6bdc7..24b73506069 100644 --- a/gcc/testsuite/cobol.dg/group2/ENTRY_statement.cob +++ b/gcc/testsuite/cobol.dg/group2/ENTRY_statement.cob @@ -6,27 +6,43 @@ working-storage section. 01 msg pic x(32). procedure division. - move "This is foo" to msg + move "This is FOO" to msg display "About to call FOO" - call "foo" using msg - move "This is bar" to msg + call "FOO" using msg + move "This is BAR" to msg display "About to call BAR" - call "bar" using msg - move "This is foo2" to msg + call "BAR" using msg + move "This is FOO2" to msg display "About to call FOO again" - call "foo" using msg + call "FOO" using msg + + move "This is BAZZ" to msg + display "About to call BAZZ" + call "BAZZ" using msg + move "This is FAZZ" to msg + display "About to call FAZZ" + call "FAZZ" using msg + move "This is baz2" to msg + display "About to call BAZZ again" + call "BAZZ" using msg + goback. end program prog. identification division. - program-id. foo. + program-id. FOO. data division. linkage section. 01 msg pic x(32). procedure division using msg. - display " entry point foo: " function trim (msg) - entry "bar" - display " entry point bar: " function trim (msg) + display " entry point FOO: " function trim (msg) + entry "BAR" + display " entry point BAR: " function trim (msg) + goback. + entry "BAZZ" + display " entry point BAZZ: " function trim (msg) + entry "FAZZ" + display " entry point FAZZ: " function trim (msg) goback. - end program foo. + end program FOO. diff --git a/gcc/testsuite/cobol.dg/group2/ENTRY_statement.out b/gcc/testsuite/cobol.dg/group2/ENTRY_statement.out index 18ba91fa5fc..b3a8053ee52 100644 --- a/gcc/testsuite/cobol.dg/group2/ENTRY_statement.out +++ b/gcc/testsuite/cobol.dg/group2/ENTRY_statement.out @@ -1,9 +1,17 @@ About to call FOO - entry point foo: This is foo - entry point bar: This is foo + entry point FOO: This is FOO + entry point BAR: This is FOO About to call BAR - entry point bar: This is bar + entry point BAR: This is BAR About to call FOO again - entry point foo: This is foo2 - entry point bar: This is foo2 + entry point FOO: This is FOO2 + entry point BAR: This is FOO2 +About to call BAZZ + entry point BAZZ: This is BAZZ + entry point FAZZ: This is BAZZ +About to call FAZZ + entry point FAZZ: This is FAZZ +About to call BAZZ again + entry point BAZZ: This is baz2 + entry point FAZZ: This is baz2 diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE___TIME_OMNIBUS.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE___TIME_OMNIBUS.cob index 536d39bb942..f23e31e8bff 100644 --- a/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE___TIME_OMNIBUS.cob +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE___TIME_OMNIBUS.cob @@ -1,5 +1,5 @@ *> { dg-do run } - *> { dg-set-target-env-var TZ UTC0 } + *> { dg-set-target-env-var TZ "UTC0" } identification division. program-id. testy. diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_with_NATIONAL_characters.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_with_NATIONAL_characters.cob new file mode 100644 index 00000000000..27b7f5d4992 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_TRIM_with_NATIONAL_characters.cob @@ -0,0 +1,55 @@ + *> { dg-do run } + *> { dg-output-file "group2/FUNCTION_TRIM_with_NATIONAL_characters.out" } + identification division. + program-id. prog. + environment division. + configuration section. + special-names. + locale cp1252 is "cp1252" + locale utf16le is "utf16le". + Object-Computer. + linux + Character Classification + for Alphanumeric is cp1252 + for National is utf16le. + data division. + working-storage section. + 01 from-8 pic x(10) value " 8888 ". + 01 from-16 pic n(10) value N" 1616 ". + 01 to-8 pic x(10). + 01 to-16 pic n(10). + procedure division. + display "Alphanumeric literal " function byte-length(from-8) + display """" from-8 """" + display """" function trim(from-8 leading ) """" + display """" function trim(from-8 trailing ) """" + display """" function trim(from-8) """" + + display "National literal " function byte-length(from-16) + display """" from-16 """" + display """" function trim(from-16 leading )"""" + display """" function trim(from-16 trailing )"""" + display """" function trim(from-16)"""" + + display "Alphanumeric data item " function byte-length(from-8) + move from-8 to to-8 + display """" to-8 """" + move function trim(from-8 leading) to to-8 + display """" to-8 """" + move function trim(from-8 trailing) to to-8 + display """" to-8 """" + move function trim(from-8) to to-8 + display """" to-8 """" + + display "National data item " function byte-length(from-16) + move from-16 to to-16 + display """" to-16 """" + move function trim(from-16 leading) to to-16 + display """" to-16 """" + move function trim(from-16 trailing) to to-16 + display """" to-16 """" + move function trim(from-16) to to-16 + display """" to-16 """" + goback. + end program prog. +