diff --git a/gcc/cobol/Make-lang.in b/gcc/cobol/Make-lang.in index 3a760eea056..a7ac8d2c5d5 100644 --- a/gcc/cobol/Make-lang.in +++ b/gcc/cobol/Make-lang.in @@ -93,11 +93,9 @@ cobol1_OBJS = \ # on all of the libgcobol/*.h files, which might lead to the occasional # unnecessary compilation. The impact of that is negligible. # -# Various #includes in the files copied from gcc/libgcobol need to be modified -# so that the .h files can be found. cobol/charmaps.cc cobol/valconv.cc: cobol/%.cc: $(LIB_SOURCE)/%.cc - sed -e '/^#include/s,"\([^"]*[^g"].h\)","../../libgcobol/\1",' $^ > $@ + cp $^ $@ LIB_SOURCE_H=$(wildcard $(LIB_SOURCE)/*.h) diff --git a/gcc/cobol/cbldiag.h b/gcc/cobol/cbldiag.h index d2919201bf8..6bb998d02d7 100644 --- a/gcc/cobol/cbldiag.h +++ b/gcc/cobol/cbldiag.h @@ -116,8 +116,9 @@ struct cbl_loc_t : public cbl_loc_base_t { last_line, last_column } {} + // cppcheck-suppress noExplicitConstructor cbl_loc_t( const cbl_loc_base_t& base ) - : cbl_loc_base_t(base) // cppcheck-suppress noExplicitConstructor + : cbl_loc_base_t(base) {} explicit cbl_loc_t( int line ) diff --git a/gcc/cobol/compare.cc b/gcc/cobol/compare.cc index f9910c98dd8..8b612d545da 100644 --- a/gcc/cobol/compare.cc +++ b/gcc/cobol/compare.cc @@ -50,6 +50,7 @@ #include "genmath.h" #include "structs.h" #include "../../libgcobol/gcobolio.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" #include "../../libgcobol/valconv.h" #include "show_parse.h" @@ -606,15 +607,15 @@ alpha_compare_figconst( tree &left, const charmap_t *charmap_left = __gg__get_charmap(left_side.field->codeset.encoding); - charmap_t *charmap_right = - __gg__get_charmap(right_side.field->codeset.encoding); +//// charmap_t *charmap_right = +//// __gg__get_charmap(right_side.field->codeset.encoding); // 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); + uint8_t char_right = char_from_figconst(figconst_right); size_t nbytes; char *converted; @@ -798,10 +799,15 @@ 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. 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); + char ach_space[4]; + char ch = ascii_space; + size_t nbytes; + const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING, + left_side.field->codeset.encoding, + &ch, + 1, + &nbytes); + memcpy(ach_space, converted, nbytes); const char *the_routine; switch( charmap_left->stride() ) { @@ -850,12 +856,12 @@ alpha_compare(tree &left, { IF( gg_indirect(location_left, count), ne_op, - build_int_cst_type(UCHAR, space_char) ) + build_int_cst_type(UCHAR, *ach_space) ) { // We have a difference. We need to calculate +1/-1 IF( gg_indirect(location_left, count), gt_op, - build_int_cst_type(UCHAR, space_char) ) + build_int_cst_type(UCHAR, *ach_space) ) { gg_assign(left, integer_one_node); } @@ -897,12 +903,12 @@ alpha_compare(tree &left, { IF( gg_indirect(location_right, count), ne_op, - build_int_cst_type(UCHAR, space_char) ) + build_int_cst_type(UCHAR, *ach_space) ) { // We have a difference. We need to calculate +1/-1 IF( gg_indirect(location_right, count), lt_op, - build_int_cst_type(UCHAR, space_char) ) + build_int_cst_type(UCHAR, *ach_space) ) { gg_assign(left, integer_one_node); } @@ -993,7 +999,7 @@ alpha_compare(tree &left, length_left, location_right, length_right, - build_int_cst_type(INT, space_char), + build_string_literal(charmap_left->stride(), ach_space), NULL_TREE); retval = true; goto done; diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 62efc19a0ea..e95c912fca7 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -50,6 +50,7 @@ #include "genmath.h" #include "structs.h" #include "../../libgcobol/gcobolio.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" #include "../../libgcobol/valconv.h" #include "show_parse.h" @@ -561,7 +562,7 @@ get_class_condition_string(cbl_field_t *var) : strlen(domain->first.name()); cbl_encoding_t from = var->codeset.default_encodings.source->type; - cbl_encoding_t to = DEFAULT_32_ENCODING; + cbl_encoding_t to = HOST_32_ENCODING; size_t nbytes; const char *converted; @@ -1204,6 +1205,15 @@ parser_statement_end( const std::list&flist) } } + +static const int DEFAULT_BYTE_MASK = 0x00000000FF; +static const int NSUBSCRIPT_MASK = 0x0000000F00; +static const int NSUBSCRIPT_SHIFT = 8; +static const int DEFAULTBYTE_BIT = 0x0000001000; +static const int EXPLICIT_BIT = 0x0000002000; +static const int REDEFINED_BIT = 0x0000004000; +static const int JUST_ONCE_BIT = 0x0000008000; + static void initialize_variable_internal( cbl_refer_t refer, bool explicitly=false, @@ -1394,14 +1404,6 @@ initialize_variable_internal( cbl_refer_t refer, } } - static const int DEFAULT_BYTE_MASK = 0x00000000FF; - static const int NSUBSCRIPT_MASK = 0x0000000F00; - static const int NSUBSCRIPT_SHIFT = 8; - static const int DEFAULTBYTE_BIT = 0x0000001000; - static const int EXPLICIT_BIT = 0x0000002000; - static const int REDEFINED_BIT = 0x0000004000; - static const int JUST_ONCE_BIT = 0x0000008000; - int flag_bits = 0; flag_bits |= explicitly ? EXPLICIT_BIT : 0; flag_bits |= is_redefined && !explicitly ? REDEFINED_BIT : 0 ; @@ -2019,11 +2021,16 @@ leave_section_internal() Analyze(); SHOW_PARSE { - if(gg_trans_unit.function_stack.size() && current_function && current_function->current_section) + if( gg_trans_unit.function_stack.size() + && current_function && current_function->current_section) { SHOW_PARSE_HEADER SHOW_PARSE_TEXT(" ") SHOW_PARSE_TEXT(current_function->current_section->label->name) + SHOW_PARSE_TEXT(" ") + fprintf(stderr, + "%p", + static_cast(current_function->current_section->label)); SHOW_PARSE_END } } @@ -3471,13 +3478,14 @@ parser_init_list() "..variables_to_init_" HOST_SIZE_T_PRINT_DEC, (fmt_size_t)current_function->our_symbol_table_index); tree array = gg_trans_unit_var_decl(ach); + + int flag_bits = wsclear() + ? DEFAULTBYTE_BIT + (*wsclear() & DEFAULT_BYTE_MASK) + : 0; gg_call(VOID, "__gg__variables_to_init", gg_pointer_to_array(array), - wsclear() ? build_string_literal( - 1, - reinterpret_cast(wsclear())) - : null_pointer_node, + build_int_cst_type(INT, flag_bits), NULL_TREE); } @@ -4368,16 +4376,16 @@ parser_accept_date_hhmmssff( struct cbl_field_t *target ) */ void -parser_alphabet( const cbl_alphabet_t& alphabet ) +parser_alphabet( const cbl_alphabet_t *alphabet ) { Analyze(); SHOW_PARSE { SHOW_PARSE_HEADER - char *psz = xasprintf(" %s ", alphabet.name); + char *psz = xasprintf(" %s ", alphabet->name); SHOW_PARSE_TEXT(psz); free(psz); - switch(alphabet.encoding) + switch(alphabet->encoding) { case iconv_CP1252_e: psz = xasprintf("CP1252"); @@ -4395,10 +4403,10 @@ parser_alphabet( const cbl_alphabet_t& alphabet ) psz = xasprintf("UTF8"); break; case custom_encoding_e: - psz = xasprintf("%s", alphabet.name); + psz = xasprintf("%s", alphabet->name); break; default: - { const char * p = __gg__encoding_iconv_name( alphabet.encoding ); + { const char * p = __gg__encoding_iconv_name( alphabet->encoding ); psz = xasprintf("%s", p? p : "[unknown]"); } } @@ -4408,7 +4416,7 @@ parser_alphabet( const cbl_alphabet_t& alphabet ) SHOW_PARSE_END } - switch(alphabet.encoding) + switch(alphabet->encoding) { case iconv_CP1252_e: case ASCII_e: @@ -4419,7 +4427,7 @@ parser_alphabet( const cbl_alphabet_t& alphabet ) case custom_encoding_e: { - uint64_t alphabet_index = symbol_unique_index(symbol_elem_of(&alphabet)); + uint64_t alphabet_index = symbol_unique_index(symbol_elem_of(alphabet)); unsigned char ach[256]; @@ -4430,21 +4438,21 @@ parser_alphabet( const cbl_alphabet_t& alphabet ) // character i has the ordinal alphabet[i] unsigned char ch = i; - ach[ch] = (alphabet.collation_sequence[i]); + ach[ch] = (alphabet->collation_sequence[i]); gg_assign( gg_array_value(table256, ch), - build_int_cst_type(UCHAR, (alphabet.collation_sequence[i])) ); + build_int_cst_type(UCHAR, (alphabet->collation_sequence[i])) ); } - unsigned int low_char = alphabet.low_char; - unsigned int high_char = alphabet.high_char; - __gg__alphabet_create(alphabet.encoding, + unsigned int low_char = alphabet->low_char; + unsigned int high_char = alphabet->high_char; + __gg__alphabet_create(alphabet->encoding, alphabet_index, ach, low_char, high_char); gg_call(VOID, "__gg__alphabet_create", - build_int_cst_type(INT, alphabet.encoding), + build_int_cst_type(INT, alphabet->encoding), build_int_cst_type(SIZE_T, alphabet_index), gg_pointer_to_array(table256), build_int_cst_type(INT, low_char), @@ -4461,16 +4469,16 @@ parser_alphabet( const cbl_alphabet_t& alphabet ) } void -parser_alphabet_use( cbl_alphabet_t& alphabet ) +parser_alphabet_use( const cbl_alphabet_t *alphabet ) { Analyze(); SHOW_PARSE { SHOW_PARSE_HEADER - char *psz = xasprintf(" %s ", alphabet.name); + char *psz = xasprintf(" %s ", alphabet->name); SHOW_PARSE_TEXT(psz); free(psz); - switch(alphabet.encoding) + switch(alphabet->encoding) { case iconv_CP1252_e: psz = xasprintf("CP1252"); @@ -4488,7 +4496,7 @@ parser_alphabet_use( cbl_alphabet_t& alphabet ) psz = xasprintf("UTF8"); break; case custom_encoding_e: - psz = xasprintf("%s", alphabet.name); + psz = xasprintf("%s", alphabet->name); break; default: gcc_unreachable(); @@ -4498,11 +4506,11 @@ parser_alphabet_use( cbl_alphabet_t& alphabet ) SHOW_PARSE_END } - uint64_t alphabet_index = symbol_unique_index(symbol_elem_of(&alphabet)); + uint64_t alphabet_index = symbol_unique_index(symbol_elem_of(alphabet)); current_function->alphabet_in_use = true; - switch(alphabet.encoding) + switch(alphabet->encoding) { default: gcc_unreachable(); @@ -4517,7 +4525,7 @@ parser_alphabet_use( cbl_alphabet_t& alphabet ) "__gg__alphabet_use", build_int_cst_type(INT, current_encoding(display_encoding_e)), build_int_cst_type(INT, current_encoding(national_encoding_e)), - build_int_cst_type(INT, alphabet.encoding), + build_int_cst_type(INT, alphabet->encoding), null_pointer_node, NULL_TREE); break; @@ -4534,7 +4542,7 @@ parser_alphabet_use( cbl_alphabet_t& alphabet ) "__gg__alphabet_use", build_int_cst_type(INT, current_encoding(display_encoding_e)), build_int_cst_type(INT, current_encoding(national_encoding_e)), - build_int_cst_type(INT, alphabet.encoding), + build_int_cst_type(INT, alphabet->encoding), build_int_cst_type(SIZE_T, alphabet_index), NULL_TREE); break; @@ -5545,8 +5553,8 @@ parser_exit_program() static void -program_end_stuff(cbl_refer_t refer, - ec_type_t ec) +program_end_stuff(const cbl_refer_t &refer, + ec_type_t ec) { // Looking for hijack here puts the hijacked code just before the // exit sequence @@ -5576,9 +5584,7 @@ program_end_stuff(cbl_refer_t refer, if( returner ) { cbl_field_type_t field_type = returner->type; - size_t nbytes = 0; - tree return_type = tree_type_from_field_type(returner, - nbytes); + tree return_type = tree_type_from_field(returner); tree retval = gg_define_variable(return_type); gg_assign(retval, gg_cast(return_type, integer_zero_node)); @@ -5591,21 +5597,22 @@ program_end_stuff(cbl_refer_t refer, || field_type == FldPointer || field_type == FldIndex ) { - // These are easily handled because they are all little-endian. + // These are easily handled because they are all native binary gg_memcpy(gg_get_address_of(retval), member(returner, "data"), build_int_cst_type( SIZE_T, - std::min(nbytes, (size_t)returner->data.capacity()))); + std::min(gg_sizeof(return_type), + (size_t)returner->data.capacity()))); } else { // The field_type has a PICTURE string, so we need to convert from the - // COBOL form to little-endian binary: + // COBOL form to native binary: tree value; - get_binary_value( value, returner, INT128); + get_binary_value( value, returner, return_type); gg_memcpy(gg_get_address_of(retval), gg_get_address_of(value), - build_int_cst_type(SIZE_T, nbytes)); + build_int_cst_type(SIZE_T, gg_sizeof(return_type))); } restore_local_variables(); gg_return(retval); @@ -6286,29 +6293,15 @@ establish_using(size_t nusing, // This code is relevant at compile time. It takes each // expected formal parameter and tacks it onto the end of the // function's arguments chain. - char *ach = xasprintf("_p_%s", args[i].refer.field->name); - - size_t nbytes = 0; - tree par_type = tree_type_from_field_type(args[i].refer.field, nbytes); - if( par_type == FLOAT ) + tree par_type; + if( args[i].crv == by_value_e ) { - if( nbytes == 16 ) - { - par_type = INT128; - } - else - { - par_type = SSIZE_T; - } - } - if( par_type == DOUBLE ) - { - par_type = SSIZE_T; + par_type = tree_type_from_refer(args[i].refer); } - if( par_type == FLOAT128 ) + else { - par_type = INT128; + par_type = VOID_P; } chain_parameter_to_function(current_function->function_decl, par_type, ach); free(ach); @@ -6369,7 +6362,7 @@ establish_using(size_t nusing, tree rt_i = gg_define_int(); for(size_t i=0; ivar_decl_node, "capacity"), gg_array_value(var_decl_call_parameter_lengths, rt_i)); } @@ -6454,6 +6446,39 @@ establish_using(size_t nusing, gg_assign(reference, gg_cast(UCHAR_P, null_pointer_node)); } ENDIF + if( cobol_target_big_endian() // cppcheck-suppress knownConditionTrueFalse + && ( args[i].refer.field->type == FldNumericBin5 + || args[i].refer.field->type == FldNumericBinary) ) + { + // We have another thing to think about. The reference we are + // processing might have come from an intermediate, and those are + // sixteen-byte values. On a little-endian machine we can just use + // the value as-is, because the extra zeroes are to the right of the + // one we need. But a big endian sixteen-byte value has a bunch of + // leading zeroes, and we need to skip past them. + tree offset = gg_define_variable(SIZE_T); + // Pick up the length metadata. + gg_assign(offset, + gg_array_value(var_decl_call_parameter_lengths, rt_i)); + + // That value is probably sixteen. Subtract the length of our target + // value from that. + gg_assign(offset, + gg_subtract(offset, + member(args[i].refer.field->var_decl_node, + "capacity"))); + // And add that value to 'reference' + gg_assign(reference, gg_add(reference, offset)); + // This code was added when I encountered a function call using + // func( N - 1 ), where the function expected a single-byte value. + // In little-endian, no problem, because the calculated value of 3 + // produced a sixteen-byte 0x03 00 00 00..... But in big-endian, + // the sixteen bytes are 0x00 00 00 00 ... 00 03. The above + // calculation starts with sixteen, subtracts one from it to get + // fifteen, and then adds fifteen to 'reference' to point to the + // 0x03. + } + // 'parameter' is a reference, so it it becomes the data member of // the cblc_field_t COBOL variable. gg_assign(member(args[i].field()->var_decl_node, "data"), reference); @@ -6465,19 +6490,7 @@ establish_using(size_t nusing, if( crv == by_value_e ) { - size_t nbytes; - tree_type_from_field_type(new_var, nbytes); - tree parm = gg_define_variable(INT128); - - tree value_type; - if( nbytes == 16 ) - { - value_type = INT128; - } - else - { - value_type = SSIZE_T; - } + tree value_type = tree_type_from_field(new_var); // 'parameter' is the 64-bit or 128-bit value that was placed on the stack tree value = gg_define_variable(value_type); @@ -6495,10 +6508,9 @@ establish_using(size_t nusing, // These are subsequent parameters parameter = TREE_CHAIN(parameter); } - gg_assign(value, gg_cast(value_type, parameter)); gg_memcpy(gg_get_address_of(value), gg_get_address_of(parameter), - build_int_cst_type(SIZE_T, nbytes)); + build_int_cst_type(SIZE_T, gg_sizeof(value))); if( args[i].refer.field->attr & any_length_e ) { @@ -6519,41 +6531,8 @@ establish_using(size_t nusing, } ENDIF - if( nbytes <= 8 ) - { - // Our input is a 64-bit number - if( new_var->attr & signable_e ) - { - IF( gg_bitwise_and( gg_cast(SIZE_T, value), - build_int_cst_type(SIZE_T, 0x8000000000000000ULL)), - ne_op, - gg_cast(SIZE_T, integer_zero_node) ) - { - // Our input is a negative number. Set it to -1, so that the - // eight high-order bytes are 0xFF - gg_assign(parm, gg_cast(INT128, integer_minus_one_node)); - } - ELSE - { - // Our input is a positive number, so set it to zero, so that - // the eight high-order bytes are 0x00 - gg_assign(parm, gg_cast(INT128, integer_zero_node)); - } - ENDIF - } - else - { - // This is a 64-bit positive number: so set it to zero, so that - // the eight high-order bytes are 0x00 - gg_assign(parm, gg_cast(INT128, integer_zero_node)); - } - } - - // Now copy over the little-endian binary bytes, either 8 or 16 as - // necessary - gg_memcpy(gg_get_address_of(parm), - gg_get_address_of(value), - build_int_cst_type(SIZE_T, nbytes)); + // Because new_var is linkage, at this point it has no data area. We + // need to create that data area. tree array_type = build_array_type_nelts(UCHAR, new_var->data.capacity()); tree data_decl_node = gg_define_variable( array_type, NULL, @@ -6561,12 +6540,21 @@ establish_using(size_t nusing, gg_assign( member(new_var->var_decl_node, "data"), gg_pointer_to_array(data_decl_node) ); - // And then move it into place - gg_call(VOID, - "__gg__assign_value_from_stack", - gg_get_address_of(new_var->var_decl_node), - parm, - NULL_TREE); + // And then put 'value' into place: + if( new_var->type == FldFloat ) + { + gg_memcpy(member(new_var->var_decl_node, "data"), + gg_get_address(value), + build_int_cst_type(SIZE_T, new_var->data.capacity())); + } + else + { + gg_call(VOID, + "__gg__assign_value_from_stack", + gg_get_address_of(new_var->var_decl_node), + gg_cast(INT128, value), + NULL_TREE); + } // We now have to handle an oddball situation. It's possible we are // dealing with // @@ -10807,8 +10795,9 @@ parser_trim( cbl_field_t *tgt, gcc_assert(how >= 1 && how <= 3); if( !handle_gg_trim(tgt, input, how, args) ) { + // We know stride is bigger than 1. cbl_encoding_t encoding = input.field->codeset.encoding; - charmap_t *charmap = __gg__get_charmap(encoding); + const charmap_t *charmap = __gg__get_charmap(encoding); int stride = charmap->stride(); tree tstride = build_int_cst_type(SIZE_T, stride); @@ -10827,15 +10816,24 @@ parser_trim( cbl_field_t *tgt, (arg.field->attr & FIGCONST_MASK); if( figconst ) { - uint8_t figcst = charmap->figconst_character(figconst); - tree tfigcst = build_int_cst_type(ULONG, figcst); + char space[] = " "; + *space = char_from_figconst(figconst); + // Convert that character to the encoded version: + size_t nbytes; + const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING, + encoding, + space, + 1, + &nbytes); + // And add it to the array: gg_memcpy(char_p, - gg_get_address_of(tfigcst), - tstride ); + build_string_literal(stride, converted), + tstride); } else { + // It's not a figurative constant, so we get our value from 'arg' tree location; get_location(location, arg); gg_memcpy(char_p, @@ -11644,7 +11642,7 @@ parser_sort(cbl_refer_t tableref, if( alphabet ) { push_program_state(); - parser_alphabet_use(*alphabet); + parser_alphabet_use(alphabet); } gg_call(VOID, "__gg__sort_table", @@ -11792,7 +11790,7 @@ parser_file_sort( cbl_file_t *workfile, if( alphabet ) { push_program_state(); - parser_alphabet_use(*alphabet); + parser_alphabet_use(alphabet); } gg_call(VOID, "__gg__sort_workfile", @@ -12077,7 +12075,7 @@ gg_array_of_file_pointers( size_t N, void parser_file_merge( cbl_file_t *workfile, - cbl_alphabet_t *alphabet, + const cbl_alphabet_t *alphabet, const std::vector& keys, size_t ninputs, cbl_file_t **inputs, @@ -12193,7 +12191,7 @@ parser_file_merge( cbl_file_t *workfile, if( alphabet ) { push_program_state(); - parser_alphabet_use(*alphabet); + parser_alphabet_use(alphabet); } gg_call(VOID, "__gg__merge_files", @@ -12639,16 +12637,23 @@ create_and_call(size_t narg, crv = by_value_e; } - if( args[i].attr == address_of_e || args[i].refer.addr_of ) + if( args[i].attr == address_of_e + || args[i].attr == length_of_e + || args[i].refer.addr_of ) { - // ADDRESS OF has to be passed by value. + // These have to be passed to be passed by value. crv = by_value_e; } + else if( crv == by_value_e && args[i].refer.field->type == FldAlphanumeric) + { + // Maybe passing an alphanumeric BY VALUE should be a syntax error? + crv = by_content_e; + } allocated[i] = 0; - tree location = gg_define_variable(UCHAR_P, "..location.1", vs_stack); - tree length = gg_define_variable(SIZE_T, "..length.1", vs_stack); + tree location = gg_define_variable(UCHAR_P); + tree length = gg_define_variable(SIZE_T); if( !args[i].refer.field ) { @@ -12665,7 +12670,8 @@ create_and_call(size_t narg, { crv = by_content_e; gg_assign(location, - gg_cast(UCHAR_P, build_string_literal(args[i].refer.field->data.capacity(), + gg_cast(UCHAR_P, + build_string_literal(args[i].refer.field->data.capacity(), args[i].refer.field->data.original()))); gg_assign(length, build_int_cst_type( SIZE_T, @@ -12718,29 +12724,10 @@ create_and_call(size_t narg, switch(args[i].attr) { case address_of_e: - { - // Allocate the memory, and make the copy: - arguments[i] = gg_define_char_star(); - allocated[i] = 1; - gg_assign(arguments[i], gg_malloc(length) ) ; - gg_memcpy(arguments[i], - location, - length); - break; - } - case length_of_e: { - // The BY CONTENT LENGTH OF gets passed as an 64-bit big-endian - // value - arguments[i] = gg_define_size_t(); - allocated[i] = 1; - gg_assign(arguments[i], gg_malloc(length) ) ; - gg_call(VOID, - "__gg__copy_as_big_endian", - gg_get_address_of(arguments[i]), - length, - NULL_TREE); + // Up above, we converted these to by_value_e + gcc_unreachable(); break; } @@ -12759,9 +12746,8 @@ create_and_call(size_t narg, case by_value_e: { - // For BY VALUE, we take whatever we've been given and do our best to - // make a 64-bit value out of it, although we move to 128 bits when - // necessary. + // For BY VALUE, we take whatever we've been given and make a INT128 + // out of it if necessary, and either LONG or ULONG otherwise. cbl_ffi_arg_attr_t attr = args[i].attr; if( args[i].refer.addr_of ) @@ -12775,7 +12761,7 @@ create_and_call(size_t narg, { arguments[i] = gg_define_size_t(); gg_assign(arguments[i], gg_cast(SIZE_T, location )); - gg_assign(length, build_int_cst_type(SIZE_T, 8)); + gg_assign(length, build_int_cst_type(SIZE_T, gg_sizeof(CHAR_P))); break; } @@ -12783,61 +12769,15 @@ create_and_call(size_t narg, { arguments[i] = gg_define_size_t(); gg_assign(arguments[i], gg_cast(SIZE_T, length)); - gg_assign(length, build_int_cst_type(SIZE_T, 8)); + gg_assign(length, build_int_cst_type(SIZE_T, gg_sizeof(CHAR_P))); break; } case none_of_e: { - assert(args[i].refer.field); - bool as_int128 = false; - if( !(args[i].refer.field->attr & intermediate_e) ) - { - // All temporaries are SIZE_T - if( args[i].refer.field->type == FldFloat ) - { - as_int128 = true; - } - else if( args[i].refer.field->type == FldNumericBin5 - && args[i].refer.field->data.digits == 0 - && args[i].refer.field->data.capacity() == 16 ) - { - as_int128 = true; - } - else if( args[i].refer.field->data.digits > 18 ) - { - as_int128 = true; - } - } - - if( as_int128 ) - { - arguments[i] = gg_define_variable(INT128); - gg_assign(arguments[i], - gg_cast(INT128, - gg_call_expr( - INT128, - "__gg__fetch_call_by_value_value", - gg_get_address_of(args[i].refer.field->var_decl_node), - refer_offset(args[i].refer), - refer_size_source(args[i].refer), - NULL_TREE))); - gg_assign(length, build_int_cst_type(SIZE_T, 16)); - } - else - { - arguments[i] = gg_define_size_t(); - gg_assign(arguments[i], - gg_cast(SIZE_T, - gg_call_expr( - INT128, - "__gg__fetch_call_by_value_value", - gg_get_address_of(args[i].refer.field->var_decl_node), - refer_offset(args[i].refer), - refer_size_source(args[i].refer), - NULL_TREE))); - gg_assign(length, build_int_cst_type(SIZE_T, 8)); - } + tree type = tree_type_from_refer(args[i].refer); + arguments[i] = gg_define_variable(type); + safe_assign(arguments[i], args[i].refer); break; } } @@ -12875,7 +12815,6 @@ create_and_call(size_t narg, // Fetch the FUNCTION_DECL for that FUNCTION_TYPE tree function_decl = gg_build_fn_decl(funcname, fndecl_type); set_call_convention(function_decl, current_call_convention()); - // Take the address of the function decl: tree address_of_function = gg_get_address_of(function_decl); @@ -12998,7 +12937,7 @@ create_and_call(size_t narg, { // There is no explicit location to assign the returned value. push_program_state(); - if( dialect_ibm() ) + if( dialect_ibm() || dialect_mf() || dialect_gnu() ) { // Because no explicit returning value is expected, we call the // designated function and assign the return value to our RETURN-CODE. @@ -13006,8 +12945,8 @@ create_and_call(size_t narg, } else { - // Because it is not IBM, we execute the called function and ignore the - // any returned value. + // Because it is not IBM/MF/GNU, we execute the called function and + // ignore any returned value. gg_append_statement(call_expr); } pop_program_state(); @@ -14290,7 +14229,7 @@ actually_create_the_static_field( cbl_field_t *new_var, } else if( new_var->type == FldClass ) { - encoding = DEFAULT_32_ENCODING; + encoding = HOST_32_ENCODING; } else { @@ -14939,7 +14878,7 @@ parser_symbol_add(struct cbl_field_t *new_var ) size_t converted_length; const char *converted = __gg__iconverter( new_var->codeset.default_encodings.source->type, - DEFAULT_32_ENCODING, + HOST_32_ENCODING, level_88_string, level_88_string_size, // Convert the NUL &converted_length); diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h index 10bbf007437..a09246be6de 100644 --- a/gcc/cobol/genapi.h +++ b/gcc/cobol/genapi.h @@ -88,9 +88,9 @@ void parser_accept_date_dow( cbl_field_t *tgt ); void parser_accept_date_hhmmssff( cbl_field_t *tgt ); void -parser_alphabet( const cbl_alphabet_t& alphabet ); +parser_alphabet( const cbl_alphabet_t *alphabet ); void -parser_alphabet_use( cbl_alphabet_t& alphabet ); +parser_alphabet_use( const cbl_alphabet_t *alphabet ); void parser_allocate( cbl_refer_t size_or_based, cbl_refer_t returning, bool initialized ); @@ -460,8 +460,8 @@ parser_file_sort( cbl_file_t *file, cbl_perform_tgt_t *out_proc ); void parser_file_merge( cbl_file_t *file, - cbl_alphabet_t *alphabet, - const std::vector& keys, + const cbl_alphabet_t *alphabet, + const std::vector& keys, size_t ninput, cbl_file_t **inputs, size_t noutput, diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc index b3a89f9b899..3034cc752b8 100644 --- a/gcc/cobol/genmath.cc +++ b/gcc/cobol/genmath.cc @@ -30,6 +30,7 @@ #include "cobol-system.h" #include "coretypes.h" #include "tree.h" +#include "tm.h" #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" #include "util.h" @@ -42,6 +43,7 @@ #include "gengen.h" #include "structs.h" #include "../../libgcobol/gcobolio.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" #include "show_parse.h" diff --git a/gcc/cobol/genutil.cc b/gcc/cobol/genutil.cc index e2b7f1c293b..b26a0993009 100644 --- a/gcc/cobol/genutil.cc +++ b/gcc/cobol/genutil.cc @@ -54,6 +54,7 @@ #include "genutil.h" #include "structs.h" #include "../../libgcobol/gcobolio.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" #include "show_parse.h" #include "../../libgcobol/exceptl.h" @@ -2019,6 +2020,20 @@ binary_from_numdisp(tree &value, tree sign_location = gg_define_variable(UCHAR_P); + // We need to be able to handle encodings that are big-endian. We do that + // here with a little bit of a stunt. The 'location' we are handed points + // to the UCHAR that is the leftmost digit of a little-endian encoded value. + + // By adding offset-1 to that value, we point to the UCHAR that is the + // leftmost digit of a big-endian encoding. The subsequent processing all + // works off that base location. + if( charmap->is_big_endian() ) + { + gg_assign(location, + gg_add(location, + build_int_cst_type(SIZE_T, fstride-1))); + } + if( field->attr & signable_e ) { // The value is signable. @@ -2523,8 +2538,8 @@ get_binary_value(tree &value, const cbl_refer_t &refer, 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. - + 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. */ @@ -2655,7 +2670,7 @@ safe_cast(tree &target, // A defined variable. { /* The construction here does the safe equivalent of - int target = *(int *)location. + target = *( *)location. It does this by copying through memcpy rather than dereferencing source_location as a source_type pointer. This avoids creating a typed @@ -2674,6 +2689,8 @@ void safe_cast(tree &target, // A defined variable. const cbl_field_t *field) { + // Use this routine when you know the data at the field->location is + // of the source_type. tree source_type = tree_type_from_field(field); tree source_location; get_location(source_location, field); @@ -2684,12 +2701,40 @@ void safe_cast(tree &target, // A defined variable. const cbl_refer_t &refer) { + // Use this routine when you know the data at the refer/field->location is + // of the source_type. 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 +safe_assign(tree target, // A defined variable. + const cbl_field_t *field) + { + // This routine extracts a binary value from 'field', and safely assigns it + // to the target. + tree dest_type = TREE_TYPE(target); + tree source_type = tree_type_from_field(field); + tree source; + get_binary_value(source, field, source_type); + gg_assign(target, gg_cast(dest_type, source)); + } + +void +safe_assign(tree target, // A defined variable. + const cbl_refer_t &refer) + { + // This routine extracts a binary value from 'field', and safely assigns it + // to the target. + tree dest_type = TREE_TYPE(target); + tree source_type = tree_type_from_refer(refer); + tree source; + get_binary_value(source, refer, source_type); + gg_assign(target, gg_cast(dest_type, source)); + } + void get_length(tree &retval, const cbl_refer_t &refer) { diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h index dbd001740dd..dd96ea3ff34 100644 --- a/gcc/cobol/genutil.h +++ b/gcc/cobol/genutil.h @@ -149,4 +149,9 @@ void attribute_bit_clear(const struct cbl_field_t *var, cbl_field_attr_t bits); tree attribute_bit_get(const struct cbl_field_t *var, cbl_field_attr_t bits); void attribute_bit_set(const struct cbl_field_t *var, cbl_field_attr_t bits); +void safe_assign(tree target, // A defined variable. + const cbl_field_t *field); +void safe_assign(tree target, // A defined variable. + const cbl_refer_t &refer); + #endif diff --git a/gcc/cobol/messages.cc b/gcc/cobol/messages.cc index 347333f758c..aac9ff0a622 100644 --- a/gcc/cobol/messages.cc +++ b/gcc/cobol/messages.cc @@ -37,6 +37,7 @@ #include #include #include +#include "target.h" #undef yy_flex_debug #include @@ -61,6 +62,7 @@ #include "../../libgcobol/io.h" #include "genapi.h" #include "genutil.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" diff --git a/gcc/cobol/move.cc b/gcc/cobol/move.cc index b718992fe2a..d50d369b549 100644 --- a/gcc/cobol/move.cc +++ b/gcc/cobol/move.cc @@ -50,6 +50,7 @@ #include "genmath.h" #include "structs.h" #include "../../libgcobol/gcobolio.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" #include "../../libgcobol/valconv.h" #include "show_parse.h" @@ -262,59 +263,24 @@ mh_source_is_literalN(cbl_refer_t &destref, case FldPointer: case FldIndex: { - // We know this is a move to an eight-byte value: SHOW_PARSE1 { SHOW_PARSE_INDENT SHOW_PARSE_TEXT("mh_source_is_literalN: pointer/index") } - if( sourceref.field->data.capacity() < 8 ) - { - // There are too few bytes in sourceref - if( sourceref.field->attr & signable_e ) - { - tree highbyte = gg_define_variable(UCHAR); - // Pick up the source byte that has the sign bit. - gg_assign(highbyte, - gg_get_indirect_reference(gg_add(member(sourceref.field->var_decl_node, - "data"), - build_int_cst_type(SIZE_T, - sourceref.field->data.capacity()-1)), - integer_zero_node)); - IF( gg_bitwise_and(highbyte, build_int_cst_type(UCHAR, 0x80)), - eq_op, - build_int_cst_type(UCHAR, 0x80) ) - { - // We are dealing with a negative number - gg_memset(gg_add(member(destref.field->var_decl_node, "data"), - refer_offset(destref)), - build_int_cst_type(UCHAR, 0xFF), - build_int_cst_type(SIZE_T, 8)); - } - ELSE - gg_memset(gg_add(member(destref.field->var_decl_node, "data"), - refer_offset(destref)), - build_int_cst_type(UCHAR, 0x00), - build_int_cst_type(SIZE_T, 8)); - ENDIF - } - else - { - // The too-short source is positive. - gg_memset(gg_add(member(destref.field->var_decl_node, "data"), - refer_offset(destref)), - build_int_cst_type(UCHAR, 0x00), - build_int_cst_type(SIZE_T, 8)); - } - } + tree source; + get_binary_value(source, sourceref); - tree literalN_value = get_literalN_value(sourceref.field); - scale_by_power_of_ten_N(literalN_value, -sourceref.field->data.rdigits); - gg_memcpy(gg_add(member(destref.field->var_decl_node, "data"), - refer_offset(destref)), - gg_get_address_of(literalN_value), - build_int_cst_type(SIZE_T, sourceref.field->data.capacity())); + tree dest_type = tree_type_from_refer(destref); + tree dest = gg_define_variable(dest_type); + gg_assign(dest, gg_cast(dest_type, source)); + + tree location; + get_location(location, destref); + gg_memcpy(location, + gg_get_address_of(dest), + build_int_cst_type(SIZE_T, gg_sizeof(dest_type))); moved = true; break; diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index f7a2be95a0a..dec2f4e7dc2 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -342,6 +342,11 @@ class locale_tgt_t { #include "cobol-system.h" #include "coretypes.h" #include "tree.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "diagnostic-core.h" +#include "target.h" +#include "tm.h" #undef cobol_dialect #undef cobol_exceptions #undef yy_flex_debug @@ -356,6 +361,7 @@ class locale_tgt_t { #include "genapi.h" #include "../../libgcobol/exceptl.h" #include "exceptg.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" #include "parse_ante.h" %} @@ -15155,6 +15161,10 @@ field_binary_usage( cbl_loc_t loc, cbl_field_t *field, field->attr |= big_endian_e; __attribute__((fallthrough)); case FldNumericBin5: + if( cobol_target_big_endian() ) // cppcheck-suppress knownConditionTrueFalse + { + field->attr |= big_endian_e; + } // If no capacity yet, then no picture, infer $comp.capacity. // If field has capacity, ensure USAGE is compatible. if( field->data.capacity() > 0 ) { // PICTURE before USAGE diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h index b0b062f80dc..bfc15a9918f 100644 --- a/gcc/cobol/parse_ante.h +++ b/gcc/cobol/parse_ante.h @@ -78,7 +78,7 @@ cbl_division_t cbl_syntax_only = not_syntax_only; void mode_syntax_only( cbl_division_t division ) { cbl_syntax_only = division; - dbgmsg("%s: parsing %s, %zu errors", __func__, + dbgmsg("%s: parsing %s, %zu errors", __func__, cbl_syntax_only == not_syntax_only? "resumes" : "syntax only", nparse_error); } @@ -93,7 +93,7 @@ mode_syntax_only( const char func[], bool yn ) { __func__, cbl_syntax_only, nparse_error ); } if( was_syntax_only != cbl_syntax_only ) { - dbgmsg("%s: parsing %s, %zu errors", func, + dbgmsg("%s: parsing %s, %zu errors", func, cbl_syntax_only == not_syntax_only? "resumes" : "syntax only", nparse_error); } @@ -169,11 +169,11 @@ extern int yydebug; // These programs in libgcobol/compat are allowed to use ANY LENGTH even though // they look like top-level programs. static const std::set compat_programs { - "CBL_ALLOC_MEM", - "CBL_CHECK_FILE_EXIST", + "CBL_ALLOC_MEM", + "CBL_CHECK_FILE_EXIST", "CBL_CLOSE_FILE", - "CBL_DELETE_FILE", - "CBL_FREE_MEM", + "CBL_DELETE_FILE", + "CBL_FREE_MEM", "CBL_GET_PROGRAM_INFO", "CBL_OPEN_FILE", "CBL_READ_FILE", @@ -2170,7 +2170,7 @@ static class current_t { assert(!programs.empty()); match_proc::statements_verify(); - + const procref_t *ref = ambiguous_reference(program_index()); std::set externals = programs.top().external_targets(); @@ -2436,7 +2436,7 @@ struct prototype_type_t : public cbl_label_t { /* * For any name, there may be one prototype and one definition. A Function-ID - * cannot share a name with a Program-ID. + * cannot share a name with a Program-ID. * * std::set::insert returns an iterator to the element and boolean indicating * whether the insertion succeeded. If false, the iterator points to the @@ -2453,12 +2453,12 @@ static bool is_allowed_name( size_t isym, const cbl_label_t *L ) { if( ! p.second ) { const cbl_label_t& extant(*p.first); - // cannot have program and function by same name. + // cannot have program and function by same name. if( extant.type != L->type ) return false; - - // ok if both are prototypes of type, not if neither is. + + // ok if both are prototypes of type, not if neither is. if( extant.prototype == L->prototype ) { - return extant.prototype; + return extant.prototype; } } return p.second; // otherwise known as true @@ -2492,7 +2492,7 @@ prototype_args( const cbl_label_t *L, size_t esym ) { size_t iprog = symbol_elem_of(L)->program; assert(iprog == 0); // no containing program iprog = symbol_index(symbol_elem_of(L)); - + if( iprog < esym ) { auto p = function_prototypes.find(iprog); if( p != function_prototypes.end() ) { @@ -2509,12 +2509,12 @@ prototype_args( const char *name, size_t esym ) { auto L = symbol_program(0, name, true); // seek program prototype if( !L ) L = symbol_program(0, name); // else use definition if( !L ) L = symbol_function_any(0, name); // else prototype or definition - + return prototype_args(L, esym); } static void -verify_args( const cbl_loc_t& loc, +verify_args( const cbl_loc_t& loc, const char name[], size_t narg, const cbl_ffi_arg_t args[] ); @@ -2597,7 +2597,7 @@ size_t program_level() { return current.program_level(); } static size_t constant_index( int token ); static bool -valid_pointer_relop( const cbl_loc_t& lloc, const cbl_loc_t& oloc, const cbl_loc_t& rloc, +valid_pointer_relop( const cbl_loc_t& lloc, const cbl_loc_t& oloc, const cbl_loc_t& rloc, cbl_refer_t *lhs, relop_t op, cbl_refer_t *rhs ); static relop_t relop_of(int); @@ -3205,41 +3205,35 @@ field_capacity_error( const cbl_loc_t& loc, const cbl_field_t *field ) { #define ERROR_IF_CAPACITY(L, F) \ do { if( field_capacity_error(L, F) ) YYERROR; } while(0) -template -static void -blankit( T* beg, size_t n, T ch ) { - std::fill(beg, beg + n, ch); -} - /* * Normally blank_initial takes just a length argument and initializes * data.initial to all blanks according to the field's encoding. Optionally it - * applies a figurative constant and uses that instead. + * applies a figurative constant and uses that instead. We are going to take + * that one character, convert it to the target encoding, and then duplicate + * as necessary. */ void cbl_field_t::blank_initial( size_t nchar, cbl_figconst_t figconst ) { - charmap_t *charmap = __gg__get_charmap(codeset.encoding); - cbl_char_t space_char = figconst == normal_value_e? - charmap->mapped_character(ascii_space) - : charmap->figconst_character(figconst); - + // Set our "from" buffer to a single space + char space[] = " "; + if( figconst ) { + *space = char_from_figconst(figconst); + } + + // Convert that character to the encoded version: + size_t nbytes; + const char *converted = __gg__iconverter(DEFAULT_SOURCE_ENCODING, + codeset.encoding, + space, + 1, + &nbytes); + // Duplicate that encoded character throughout the target range: size_t nbyte = nchar * codeset.stride(); char *init = static_cast(xmalloc(nbyte+4)); - char *enit = init + nbyte; - std::fill(enit, enit + 4, '\0'); // append for NULs - - switch(codeset.stride()) { - case 1: - blankit( reinterpret_cast(init), nchar, uint8_t(space_char%0x100) ); - break; - case 2: - blankit( reinterpret_cast(init), nchar, uint16_t(space_char%0x10000) ); - break; - case 4: - blankit( reinterpret_cast(init), nchar, uint32_t(space_char) ); - break; - default: - gcc_unreachable(); + char *d = init; + for(size_t i=0; i(data.initial)); @@ -3596,7 +3590,7 @@ data_division_ready() { // Tell codegen about symbols. static size_t nsymbol = 0; size_t again(nsymbol); - + if( (nsymbol = symbols_update(nsymbol, nparse_error == 0)) > 0 ) { if( ! mode_syntax_only() ) { if( ! literally_one ) { @@ -3875,7 +3869,7 @@ void internal_ebcdic_unlock(); static cbl_field_type_t field_binary_usage( cbl_loc_t loc, cbl_field_t *field, cbl_field_type_t type, uint32_t capacity, - bool signable ); + bool signable ); void ast_end_program(const char name[] ) { @@ -3903,7 +3897,7 @@ ast_end_program(const char name[] ) { } parser_end_program(name); internal_ebcdic_unlock(); - resume_parsing(); + resume_parsing(); } static bool diff --git a/gcc/cobol/parse_util.h b/gcc/cobol/parse_util.h index 0537c60b5fd..e9e69a34eda 100644 --- a/gcc/cobol/parse_util.h +++ b/gcc/cobol/parse_util.h @@ -501,7 +501,6 @@ intrinsic_invalid_parameter( int token, case FldClass: case FldConditional: case FldForward: - case FldIndex: yyerror("%s: field '%s' (%s) invalid for %s parameter", descr.name, arg.field->name, cbl_field_type_str(arg.field->type), diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index d11bcb25ae9..45437d33418 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -39,6 +39,7 @@ #include #include +#include "tm.h" #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" #include "util.h" @@ -47,6 +48,7 @@ #include "inspect.h" #include "../../libgcobol/io.h" #include "genapi.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" #pragma GCC diagnostic ignored "-Wunused-result" @@ -1716,7 +1718,7 @@ symbols_alphabet_set( size_t program, const char name[]) { struct alpha { void operator()( symbol_elem_t& elem ) const { if( elem.type == SymAlphabet ) { - parser_alphabet( *cbl_alphabet_of(&elem) ); + parser_alphabet( cbl_alphabet_of(&elem) ); } } }; @@ -1730,7 +1732,7 @@ symbols_alphabet_set( size_t program, const char name[]) { if( !e ) { return false; } - parser_alphabet_use(*cbl_alphabet_of(e)); + parser_alphabet_use(cbl_alphabet_of(e)); } return true; // End older version @@ -3456,7 +3458,7 @@ cbl_alphabet_t::reencode( const cbl_loc_t& loc ) { const char *fromcode = __gg__encoding_iconv_name(CP1252_e); const char *tocode = __gg__encoding_iconv_name(current_encoding(display_encoding_e)); - iconv_t cd = iconv_open(tocode, fromcode); + iconv_t cd = helpful_iconv_open(tocode, fromcode); if( cd == iconv_t(-1) ) { error_msg(loc, "cannot convert from %qs to %qs: %s", fromcode, tocode, xstrerror(errno)); @@ -3508,17 +3510,38 @@ cbl_alphabet_t::reencode( const cbl_loc_t& loc ) { continue; } + /* We have a problem. We originally did collation sequences for + single-byte-coded (SBC) character sets, like ASCII and EBCDIC. But we + have the capability of multi-byte sets like UTF-16LE/BE and + UTF-32/LE/BE. What collation means in those environments is unknown to + me at this time. So, for now I am simply assuming that whatever we are + doing here fits into a single byte. + + So, for SBC or little-endian character sets, we just pick up the value + at pos[0]. For big-endian character sets, we find the low-order byte. + */ + + unsigned char ch_pos; + if( charmap_disp->is_big_endian() ) + { + ch_pos = pos[stride-1]; + } + else + { + ch_pos = pos[0]; + } + if( ch == low_index ) { - low_index = pos[0]; + low_index = ch_pos; } if( ch == last_index ) { - last_index = pos[0]; + last_index = ch_pos; } if( ch == high_index ) { - high_index = pos[0]; + high_index = ch_pos; } - tgt.at(pos[0]) = *p; + tgt.at(ch_pos) = *p; } std::copy(tgt.begin(), tgt.end(), collation_sequence); @@ -4176,7 +4199,7 @@ iconv_cd( cbl_encoding_t tgt ) { const char *tocode = __gg__encoding_iconv_name(tgt); gcc_assert(fromcode && tocode); - if( (cd = iconv_open(tocode, fromcode)) == iconv_t(-1) ) { + if( (cd = helpful_iconv_open(tocode, fromcode)) == iconv_t(-1) ) { return cd; } cds[key] = cd; @@ -4496,7 +4519,7 @@ symbol_label_add( size_t program, cbl_label_t *input ) free(psz); } - symbol_elem_t elem { program, *input }, *e = &elem; + symbol_elem_t elem { program, *input }, *e; e = symbol_append(elem); assert(e); diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc index 4cc19c3ac3e..46d1d1875a7 100644 --- a/gcc/cobol/util.cc +++ b/gcc/cobol/util.cc @@ -55,6 +55,7 @@ #include "cdfval.h" #include "lexio.h" +#include "tm.h" #include "../../libgcobol/ec.h" #include "../../libgcobol/common-defs.h" #include "symbols.h" @@ -62,6 +63,7 @@ #include "../../libgcobol/io.h" #include "genapi.h" #include "genutil.h" +#include "../../libgcobol/cobol-endian.h" #include "../../libgcobol/charmaps.h" #include "../../libgcobol/valconv.h" @@ -1814,9 +1816,47 @@ cbl_field_t::encode_numeric( const char input[], cbl_loc_t loc ) { *pretval++ = ascii_plus; } } - + if( (attr & signable_e) + && !(attr & separate_e) ) + { + // The value is signable and internal; + char *sign_loc; + if( attr & leading_e ) + { + // The sign is in the first character + sign_loc = retval; + } + else + { + // The sign is in the final character + sign_loc = retval + char_capacity() - 1; + } + if( negative ) + { + // We have to convert the very first digit into the negative flag + const charmap_t *charmap = __gg__get_charmap(codeset.encoding); + if( charmap->is_like_ebcdic() ) + { + if( *sign_loc == ascii_zero ) + { + /* When EBCDIC '0' is 0xF0. The negative flag version is 0xD0, + which is right left brace. */ + *sign_loc = ascii_rbrace; + } + else + { + /* EBCDIC '1' through '9' is 0xF1 through 0xF9, and they need + to be converted to 0xD0 through 0xD9. */ + *sign_loc = (*sign_loc - ascii_zero) + ascii_J-1; + } + } + else + { + *sign_loc = (*sign_loc - ascii_zero) + ascii_p; + } + } + } // It's at this point we convert to the target encoding: - charmap_t *charmap = __gg__get_charmap(codeset.encoding); size_t retval_length = pretval - retval; if( retval_length != char_capacity() ) { cbl_errx( "%s: %s %lu %s %lu", @@ -1842,38 +1882,6 @@ cbl_field_t::encode_numeric( const char input[], cbl_loc_t loc ) { } gcc_assert(nbytes == data.capacity()); memcpy(retval, converted, data.capacity()); - if( (attr & signable_e) - && !(attr & separate_e) ) - { - // This value is signable, and not separate. So, the sign - // information goes into the first or last byte: - char *sign_location = attr & leading_e - ? retval - : retval + (data.digits-1) * charmap->stride() ; - cbl_char_t schar = charmap->set_digit_negative(*sign_location, - negative); - switch(charmap->stride()) - { - case 1: - { - uint8_t v = schar; - memcpy(sign_location, &v, charmap->stride()); - break; - } - case 2: - { - uint16_t v = schar; - memcpy(sign_location, &v, charmap->stride()); - break; - } - case 4: - { - uint32_t v = schar; - memcpy(sign_location, &v, charmap->stride()); - break; - } - } - } break; } diff --git a/gcc/testsuite/cobol.dg/group2/Assorted_SPECIAL-NAMES_CLASS.cob b/gcc/testsuite/cobol.dg/group2/Assorted_SPECIAL-NAMES_CLASS.cob index e40122d00de..670c5556175 100644 --- a/gcc/testsuite/cobol.dg/group2/Assorted_SPECIAL-NAMES_CLASS.cob +++ b/gcc/testsuite/cobol.dg/group2/Assorted_SPECIAL-NAMES_CLASS.cob @@ -14,7 +14,7 @@ *> to declare what is "right". This code works with ASCII, EBCDIC, *> and UTF-8 as the ALPHANUMERIC/DISPLAY encoding. - locale unicode is "utf16le" + locale unicode is "utf16" CLASS HexNumber IS "0" THRU "9", "A" THRU "F", "a" THRU "f" CLASS RealName IS "A" THRU "Z", diff --git a/gcc/testsuite/cobol.dg/group2/BINARY_and_COMP-5__little-endian_.cob b/gcc/testsuite/cobol.dg/group2/BINARY_and_COMP-5__little-endian_.cob new file mode 100644 index 00000000000..4a9fed55251 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/BINARY_and_COMP-5__little-endian_.cob @@ -0,0 +1,158 @@ + *> { dg-do run } + *> { dg-output-file "group2/BINARY_and_COMP-5__little-endian_.out" } + identification division. + program-id. prog. + procedure division. + call "prog1" + call "prog2" + goback. + end program prog. + + identification division. + program-id. prog1. + data division. + working-storage section. + 01. + 02 var-binary binary pic 9v9(10) . + 02 var-binaryp redefines var-binary pointer. + 02 var-comp comp pic 9v9(10) . + 02 var-compp redefines var-comp pointer. + 02 var-compu computational pic 9v9(10) . + 02 var-compup redefines var-compu pointer. + 02 var-comp4 comp-4 pic 9v9(10) . + 02 var-comp4p redefines var-comp4 pointer. + 02 var-compu4 computational-4 pic 9v9(10) . + 02 var-compu4p redefines var-compu4 pointer. + + 02 var-comp5 comp-5 pic 9v9(10) . + 02 var-comp5p redefines var-comp5 pointer. + 02 var-compu5 computational-5 pic 9v9(10) . + 02 var-compu5p redefines var-compu5 pointer. + + 02 var-sbinary binary pic s9v9(10) . + 02 var-sbinaryp redefines var-sbinary pointer. + 02 var-scomp comp pic s9v9(10) . + 02 var-scompp redefines var-scomp pointer. + 02 var-scompu computational pic s9v9(10) . + 02 var-scompup redefines var-scompu pointer. + 02 var-scomp4 comp-4 pic s9v9(10) . + 02 var-scomp4p redefines var-scomp4 pointer. + 02 var-scompu4 computational-4 pic s9v9(10) . + 02 var-scompu4p redefines var-scompu4 pointer. + + 02 var-scomp5 comp-5 pic s9v9(10) . + 02 var-scomp5p redefines var-scomp5 pointer. + 02 var-scompu5 computational-5 pic s9v9(10) . + 02 var-scompu5p redefines var-scompu5 pointer. + procedure division. + move 0.0001193046 to var-binary var-comp var-compu + var-comp4 var-compu4 var-comp5 + var-compu5 + display " " var-binary " " var-comp " " var-compu " " + var-comp4 " " var-compu4 " " + var-comp5 " " var-compu5 + move 0.0001193046 to var-sbinary var-scomp var-scompu + var-scomp4 var-scompu4 var-scomp5 + var-scompu5 + display var-sbinary " " var-scomp " " var-scompu " " + var-scomp4 " " var-scompu4 " " + var-scomp5 " " var-scompu5 + move -0.0001193046 to var-sbinary var-scomp var-scompu + var-scomp4 var-scompu4 var-scomp5 + var-scompu5 + display var-sbinary " " var-scomp " " var-scompu " " + var-scomp4 " " var-scompu4 " " + var-scomp5 " " var-scompu5 + display var-binaryp + display var-compp + display var-compup + display var-comp4p + display var-compu4p + display var-comp5p + display var-compu5p + + display var-sbinaryp + display var-scompp + display var-scompup + display var-scomp4p + display var-scompu4p + display var-scomp5p + display var-scompu5p + + goback. + end program prog1. + + identification division. + program-id. prog2. + data division. + working-storage section. + 01. + 02 var-binary pic 9v9(10) binary . + 02 var-binaryp redefines var-binary pointer. + 02 var-comp pic 9v9(10) comp . + 02 var-compp redefines var-comp pointer. + 02 var-compu pic 9v9(10) computational . + 02 var-compup redefines var-compu pointer. + 02 var-comp4 pic 9v9(10) comp-4 . + 02 var-comp4p redefines var-comp4 pointer. + 02 var-compu4 pic 9v9(10) computational-4 . + 02 var-compu4p redefines var-compu4 pointer. + + 02 var-comp5 pic 9v9(10) comp-5 . + 02 var-comp5p redefines var-comp5 pointer. + 02 var-compu5 pic 9v9(10) computational-5 . + 02 var-compu5p redefines var-compu5 pointer. + + 02 var-sbinary pic s9v9(10) binary . + 02 var-sbinaryp redefines var-sbinary pointer. + 02 var-scomp pic s9v9(10) comp . + 02 var-scompp redefines var-scomp pointer. + 02 var-scompu pic s9v9(10) computational . + 02 var-scompup redefines var-scompu pointer. + 02 var-scomp4 pic s9v9(10) comp-4 . + 02 var-scomp4p redefines var-scomp4 pointer. + 02 var-scompu4 pic s9v9(10) computational-4 . + 02 var-scompu4p redefines var-scompu4 pointer. + + 02 var-scomp5 pic s9v9(10) comp-5 . + 02 var-scomp5p redefines var-scomp5 pointer. + 02 var-scompu5 pic s9v9(10) computational-5 . + 02 var-scompu5p redefines var-scompu5 pointer. + procedure division. + move 0.0001193046 to var-binary var-comp var-compu + var-comp4 var-compu4 var-comp5 + var-compu5 + display " " var-binary " " var-comp " " var-compu " " + var-comp4 " " var-compu4 " " + var-comp5 " " var-compu5 + move 0.0001193046 to var-sbinary var-scomp var-scompu + var-scomp4 var-scompu4 var-scomp5 + var-scompu5 + display var-sbinary " " var-scomp " " var-scompu " " + var-scomp4 " " var-scompu4 " " + var-scomp5 " " var-scompu5 + move -0.0001193046 to var-sbinary var-scomp var-scompu + var-scomp4 var-scompu4 var-scomp5 + var-scompu5 + display var-sbinary " " var-scomp " " var-scompu " " + var-scomp4 " " var-scompu4 " " + var-scomp5 " " var-scompu5 + display var-binaryp + display var-compp + display var-compup + display var-comp4p + display var-compu4p + display var-comp5p + display var-compu5p + + display var-sbinaryp + display var-scompp + display var-scompup + display var-scomp4p + display var-scompu4p + display var-scomp5p + display var-scompu5p + + goback. + end program prog2. +