From: Robert Dubner <[email protected]>
Date: Wed, 16 Sep 2026 22:01:46 -0400
Subject: [PATCH] cobol: Refactor numeric-editing formatting for speed.
Upon noticing that the routine that formats a string of digits in
accordance with a numeric-edited PICTURE string has been running very
slowly, I have broken out a specific routine for handling ASCII strings,
which eliminates the costly conversion to an arbitrary encoding.
I have also refactored the underlying conversion so that it is running
about eight times faster than before.
gcc/cobol/ChangeLog:
* genapi.cc (actually_create_the_static_field): Use expanded
PICTURE
string.
* lang-specs.h: Updated cc1_options formatting string.
* move.cc (mh_source_is_literalN): Use new numeric-edited routine.
(mh_to_numeric_edited): Likewise.
(move_helper): Likewise.
* parse.y: Formatting.
* symbols.cc (symbol_file): Mollify cppcheck.
(expand_picture): Modified for numeric-editing.
* symbols.h (cbl_dialect_str): Formatting.
(enum dspc_t): Formatting.
(MAXIMUM_ALPHA_LENGTH): Formatting.
(is_elementary): Formatting.
(struct cbl_field_t): Formatting.
(struct cbl_refer_t): Formatting.
(struct parameter_t): Formatting.
(struct cbl_label_t): Formatting.
(class temporaries_t): Formatting.
(struct cbl_locale_t): Formatting.
(hex2numstr): Formatting.
(struct cbl_file_key_t): Formatting.
(struct cbl_file_t): Formatting.
(struct symbol_elem_t): Formatting.
(redefine_field): Formatting.
(is_prototypical): Formatting.
(struct cbl_prog_hier_t): Formatting.
(keyword_alias_add): Formatting.
(class current_tokens_t): Formatting.
(expand_picture): Formatting.
* util.cc (cbl_prototype_ok): Formatting.
(cdf_file): Formatting.
(repeat_count): Formatting.
(cbl_field_t::encode_numeric): Formatting; use new numeric-edited
routine.
(cbl_field_t::report_invalid_initial_value): Formatting.
(valid_move): Formatting.
(cobol_filename): Formatting.
(gcc_location_set): Formatting.
(parse_file): Formatting.
libgcobol/ChangeLog:
* gmath.cc (__gg__int128_to_int128_rounded): Change error
handling.
* libgcobol.cc (int128_to_field): Likewise.
(__gg__int128_to_ascii_numeric_display): New routine for increased
speed.
* valconv.cc (TOUPPER): Remove.
(expand_picture): Remove; it's being done in another routine.
(Lindex): Remove.
(Rindex): Remove.
(__gg__string_to_numeric_edited): Refactor for speed.
(__gg__string_to_alpha_edited): Eliminate call to
expand_picture().
(__gg__currency_sign_init): Formatting.
* valconv.h: Change __gg__string_to_numeric_edited() return type.
gcc/testsuite/ChangeLog:
* cobol.dg/group2/PR126612_-_Ignore_TRACE_-_gnu.cob: New test.
* cobol.dg/group2/PR126612_-_Ignore_TRACE_-_ibm.cob: New test.
* cobol.dg/group2/PR126612_-_Ignore_TRACE_-_iso.cob: New test.
* cobol.dg/group2/PR126612_-_Ignore_TRACE_-_mf.cob: New test.
* cobol.dg/group2/RT3611_-_BY_CONTENT_LENGTH_OF.cob: New test.
* cobol.dg/group2/__define__text_.cob: New test.
* cobol.dg/group2/__define__text_.out: New test.
* cobol.dg/group2/customer_bug_Heuristic_Fail.cob: New test.
* cobol.dg/group2/customer_bug_Heuristic_Fail.out: New test.
---
gcc/cobol/genapi.cc | 4 +-
gcc/cobol/lang-specs.h | 2 +-
gcc/cobol/move.cc | 117 +-
gcc/cobol/parse.y | 1 -
gcc/cobol/symbols.cc | 169 +-
gcc/cobol/symbols.h | 175 +--
gcc/cobol/util.cc | 93 +-
.../group2/PR126612_-_Ignore_TRACE_-_gnu.cob | 15 +
.../group2/PR126612_-_Ignore_TRACE_-_ibm.cob | 15 +
.../group2/PR126612_-_Ignore_TRACE_-_iso.cob | 15 +
.../group2/PR126612_-_Ignore_TRACE_-_mf.cob | 15 +
.../group2/RT3611_-_BY_CONTENT_LENGTH_OF.cob | 23 +
.../cobol.dg/group2/__define__text_.cob | 23 +
.../cobol.dg/group2/__define__text_.out | 3 +
.../group2/customer_bug_Heuristic_Fail.cob | 10 +
.../group2/customer_bug_Heuristic_Fail.out | 1 +
libgcobol/gmath.cc | 2 +-
libgcobol/libgcobol.cc | 43 +-
libgcobol/valconv.cc | 1371 +++++------------
libgcobol/valconv.h | 2 +-
20 files changed, 883 insertions(+), 1216 deletions(-)
create mode 100644
gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_gnu.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_ibm.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_iso.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_mf.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/RT3611_-_BY_CONTENT_LENGTH_OF.cob
create mode 100644 gcc/testsuite/cobol.dg/group2/__define__text_.cob
create mode 100644 gcc/testsuite/cobol.dg/group2/__define__text_.out
create mode 100644
gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.out
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index 71fc31852c3..5d7d553b9d8 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -14431,7 +14431,9 @@ actually_create_the_static_field( cbl_field_t
*new_var,
}
tree offset = build_int_cst_type(SIZE_T, new_var->offset);
tree name = gg_string_literal(new_var->name);
- tree picture = gg_string_literal(new_var->data.picture);
+ char *expanded = expand_picture(new_var->data.picture);
+ tree picture = gg_string_literal(expanded);
+ free(expanded);
tree initial;
if( length_of_initial_string == 0 || !new_var->data.has_initial_value()
)
{
diff --git a/gcc/cobol/lang-specs.h b/gcc/cobol/lang-specs.h
index ace1dfa0680..ea9a144c2a8 100644
--- a/gcc/cobol/lang-specs.h
+++ b/gcc/cobol/lang-specs.h
@@ -34,7 +34,7 @@
{".CBL", "@cobol", 0, 0, 0},
{"@cobol",
"cobol1 %i %(cc1_options) "
- "%{B*} %{D*} %{E} %{I*} %{M} %{fmax-errors*} %{fsyntax-only*} "
+ "%{I*} %{B*} %{D*} %{E} %{M} %{fmax-errors*} %{fsyntax-only*} "
"%{idirafter}"
"%{fcobol-exceptions*} "
"%{copyext} "
diff --git a/gcc/cobol/move.cc b/gcc/cobol/move.cc
index 6c7f8e0c11a..44df3e4f240 100644
--- a/gcc/cobol/move.cc
+++ b/gcc/cobol/move.cc
@@ -15,7 +15,7 @@
* contributors may be used to endorse or promote products derived from
* this software without specific prior written permission.
*
- * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORSdf
* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
@@ -201,7 +201,8 @@ mh_source_is_literalN(cbl_refer_t &destref,
tree size_error)
{
bool moved = false;
- if( sourceref.field->type == FldLiteralN )
+ if( sourceref.field->type == FldLiteralN
+ && destref.field->type != FldNumericEdited )
{
Analyze();
switch( destref.field->type )
@@ -348,7 +349,6 @@ mh_source_is_literalN(cbl_refer_t &destref,
case FldNumericDisplay:
case FldNumericBinary:
- case FldNumericEdited:
case FldPacked:
{
SHOW_PARSE1
@@ -1656,6 +1656,109 @@ mh_binary_to_packed(const cbl_refer_t &destref,
return moved;
}
+static bool
+mh_to_numeric_edited(const cbl_refer_t &destref,
+ const cbl_refer_t &sourceref,
+ cbl_round_t rounded,
+ tree size_error)
+ {
+ bool moved = false;
+
+ if( destref.field->type == FldNumericEdited
+ && destref.field->codeset.stride() == 1
+ && !(destref.field->attr & scaled_e)
+ && (!(sourceref.field->attr & intermediate_e) ||
sourceref.field->type == FldLiteralN)
+
+ && ( sourceref.field->type == FldNumericBinary
+ || sourceref.field->type == FldNumericBin5
+ || sourceref.field->type == FldNumericDisplay
+ || sourceref.field->type == FldLiteralN
+ || sourceref.field->type == FldIndex
+ || sourceref.field->type == FldPointer ) )
+ {
+ const charmap_t *charmap =
__gg__get_charmap(destref.field->codeset.encoding);
+ if( !charmap->is_like_ebcdic() )
+ {
+ tree value = get_binary_value(sourceref, INT128);
+
+ int scaler = 0;
+ int rdigits = sourceref.field->data.rdigits;
+ if( sourceref.field->attr & scaled_e)
+ {
+ if( sourceref.field->data.rdigits < 0 )
+ {
+ // This is like 9999PPP, where rdigits = -3
+ scaler = sourceref.field->data.rdigits;
+ rdigits = 0;
+ }
+ else
+ {
+ // This is like PPP9999, where rdigits=3 and digits=4
+ rdigits = sourceref.field->data.digits
+ + sourceref.field->data.rdigits;
+ }
+ }
+ // We have to make the source decimal point position line up with
that of
+ // the destination.
+ scaler = destref.field->data.rdigits - rdigits - scaler;
+
+ // To line up the decimal points we multiply value by 10**scaler
+ if( scaler > 0 )
+ {
+ FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten( scaler );
+ tree pot = wide_int_to_tree(INT128, power_of_ten);
+ value = gg_multiply(value, pot);
+ }
+ else if( scaler < 0 )
+ {
+ FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten( -scaler );
+ tree pot = wide_int_to_tree(INT128, power_of_ten);
+ value = gg_call_expr(INT128,
+ "__gg__int128_to_int128_rounded",
+ build_int_cst_type(INT, rounded),
+ value,
+ pot,
+ NULL_TREE);
+ }
+ // The decimal points are lined up.
+ if( size_error )
+ {
+ FIXED_WIDE_INT(128) power_of_ten =
+ get_power_of_ten(
destref.field->data.digits );
+ tree mask = wide_int_to_tree(INT128, power_of_ten);
+ IF( gg_abs(value), ge_op, mask )
+ {
+ gg_assign(gg_indirect(size_error),
+ gg_bitwise_or(gg_indirect(size_error),
+ integer_one_node));
+ }
+ ELSE
+ {
+ gg_call(INT,
+ "__gg__int128_to_ascii_numeric_display",
+ gg_get_address_of(destref.field->var_decl_node),
+ get_location(destref),
+ value,
+ NULL_TREE);
+ }
+ ENDIF
+ }
+ else
+ {
+ gg_call(INT,
+ "__gg__int128_to_ascii_numeric_display",
+ gg_get_address_of(destref.field->var_decl_node),
+ get_location(destref),
+ value,
+ NULL_TREE);
+ }
+ moved = true;
+ }
+ }
+
+ return moved;
+ }
+
static void
copy_native_into_place(cbl_field_t *dest,
tree dest_offset,
@@ -3634,6 +3737,14 @@ move_helper(tree size_error, // This is an
INT
size_error);
}
+ if( !moved )
+ {
+ moved = mh_to_numeric_edited(destref,
+ sourceref,
+ rounded,
+ size_error);
+ }
+
if( !moved )
{
SHOW_PARSE1
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index 37f4ab6358f..aa53e5f259f 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -15090,7 +15090,6 @@ dialect_words_set( cbl_dialect_t dialect ) {
typedef bool (current_tokens_t::*wordop_func_t)(const cbl_loc_t& loc,
const cbl_name_t keyword,
const cbl_name_t alias);
-
struct wordop_t {
cbl_dialect_t dialect;
wordop_func_t op;
diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc
index f732a67287b..5f6752ef746 100644
--- a/gcc/cobol/symbols.cc
+++ b/gcc/cobol/symbols.cc
@@ -3093,7 +3093,8 @@ symbol_file( size_t program, const char name[] ) {
key.program = symbol_at(key.program)->program;
p = symbols.files.find(key);
if( p != symbols.files.end() ) {
- const cbl_file_t *f = cbl_file_of(symbol_at(p->second));
+ // cppcheck-suppress constVariablePointer
+ auto f = cbl_file_of(symbol_at(p->second));
if( f->attr & global_e ) break;
}
}
@@ -4793,88 +4794,120 @@ floating_char_in_string(const char
*expanded_picture) {
char *
expand_picture(const char *picture)
+ {
+ // The caller should free() the return value.
+ assert(strlen(picture) < PICTURE_MAX); // guaranteed by picset() in
scanner
+ size_t retval_length = PICTURE_MAX;
+ char *retval = static_cast<char *>(xmalloc(retval_length));
+
+ int ch;
+ int prior_ch = NULLCH;
+ char *d = retval;
+ const char *p = picture;
+ long repeat;
+ int currency_symbol = NULLCH;
+
+ while( (ch = (*p++ & 0xFF) ) )
{
- assert(strlen(picture) < PICTURE_MAX); // guaranteed by picset() in
scanner
- size_t retval_length = PICTURE_MAX;
- char *retval = static_cast<char *>(xmalloc(retval_length));
- size_t index = 0;
-
- int ch;
- int prior_ch = '\0';
- const char *p = picture;
-
- long repeat;
+ if( ch == ascii_oparen )
+ {
+ // Pick up the number after the left parenthesis
+ char *endchar;
+ repeat = strtol(p, &endchar, 10);
- int currency_symbol = currency_char_in_string(picture);
+ // We subtract one because we know that the character just before
+ // the parenthesis was already placed in retval
+ repeat -= 1;
- while( (ch = (*p++ & 0xFF) ) )
+ // Update p to the character after the right parenthesis
+ p = endchar + 1;
+ while(repeat--)
{
- if( ch == '(' )
- {
- // Pick up the number after the left parenthesis
- char *endchar;
- repeat = strtol(p, &endchar, 10);
+ *d++ = prior_ch;
+ }
+ }
+ else
+ {
+ prior_ch = ch;
+ *d++ = ch;
+ }
- // We subtract one because we know that the character just
before
- // the parenthesis was already placed in dest
- repeat -= 1;
+ if( ! __gg__currency_signs[ch].empty() )
+ {
+ // We are going to be mapping ch to a string in the final result:
+ prior_ch = ch;
+ currency_symbol = ch;
+ }
+ }
- // Update p to the character after the right parenthesis
- p = endchar + 1;
+ size_t dest_length = d-retval;
- if( index + repeat >= retval_length )
- {
- retval_length <<= 1;
- retval = static_cast<char *>(xrealloc(retval,
retval_length));
- }
+ // We have to take into account the possibility that the currency
symbol
+ // mapping might be to a string of more than one character:
- while(repeat--)
- {
- retval[index++] = prior_ch;
- }
- }
- else
- {
- if( index >= retval_length )
- {
- retval_length <<= 1;
- retval = static_cast<char *>(xrealloc(retval,
retval_length));
- }
- retval[index++] = ch;
- }
- prior_ch = ch;
- }
- if( index >= retval_length )
+ if( currency_symbol )
+ {
+ size_t sign_length = __gg__currency_signs[currency_symbol].size();
+ assert(0 < sign_length);
+ if( --sign_length )
+ {
+ char *pcurrency = strchr(retval, currency_symbol);
+ assert(pcurrency);
+ memmove( pcurrency + sign_length,
+ pcurrency,
+ dest_length - (pcurrency-retval));
+ for(size_t i=0; i<sign_length; i++)
{
- retval_length <<= 1;
- retval = static_cast<char *>(xrealloc(retval, retval_length));
+ pcurrency[i] = ascii_B;
}
- retval[index++] = '\0';
-
- size_t dest_length = strlen(retval);
-
- // We have to take into account the possibility that the currency
symbol
- // mapping might be to a string of more than one character:
+ dest_length += sign_length;
+ }
+ }
+ retval[dest_length++] = NULLCH;
+
+ // To ease the workload on interpreting the PICTURE string at run time,
we
+ // are going to convert everything we can to upper case. We also
convert
+ // V to decimal point, for the same reason. Characters that might be
+ // currency symbols have to be left in their uppercase or lowercase
original
+ // state.
+ for(size_t i=0; i<dest_length; i++)
+ {
+ switch(retval[i])
+ {
+ case ascii_a:
+ case ascii_c:
+ case ascii_e:
+ case ascii_n:
+ case ascii_p:
+ case ascii_r:
+ case ascii_s:
+ case ascii_x:
+ case ascii_z:
+ retval[i] = TOUPPER(retval[i]);
+ break;
+ case ascii_V:
+ case ascii_v:
+ retval[i] = __gg__decimal_point;
+ break;
- if( currency_symbol )
+ // We need special processing for DB. When they appear as the
final two
+ // characters, they are the accounting sign "DB" indicator and we
have to
+ // leave the case as the programmer established it. Otherwise we
have to
+ // make the 'B' uppercase.
+
+ case ascii_B:
+ case ascii_b:
+ if( i < dest_length-1 )
{
- size_t sign_length = strlen(symbol_currency(currency_symbol)) -
1;
- if( sign_length )
- {
- char *pcurrency = strchr(retval, currency_symbol);
- assert(pcurrency);
- memmove( pcurrency + sign_length,
- pcurrency,
- dest_length+1 - (pcurrency-retval));
- for(size_t i=0; i<sign_length; i++)
- {
- pcurrency[i] = 'B';
- }
- }
+ retval[i] = TOUPPER(retval[i]);
}
- return retval;
+
+
+ }
}
+ return retval;
+ }
int
length_of_picture(const char *picture)
diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h
index 736d6e7b3a9..6c6142ed1a9 100644
--- a/gcc/cobol/symbols.h
+++ b/gcc/cobol/symbols.h
@@ -64,11 +64,11 @@ cbl_dialect_str(cbl_dialect_t dialect) {
case dialect_mf_e | dialect_gnu_e: return "mf or gnu";
case dialect_ibm_e | dialect_mf_e | dialect_gnu_e: return "ibm or mf
or gnu";
}
-
+
return "???";
}
-// Dialects may be combined.
+// Dialects may be combined.
extern unsigned int cbl_dialects;
void cobol_dialect_set( cbl_dialect_t dialect );
@@ -127,61 +127,61 @@ enum cbl_division_t {
*/
enum dspc_t {
dspc_identification_div_e,
- dspc_options_para_e,
- dspc_arithmetic_clause_e,
- dspc_default_rounded_clause_e,
- dspc_entry_convention_clause_e,
- dspc_float_binary_clause_e,
- dspc_float_decimal_clause_e,
- dspc_initialize_clause_e,
- dspc_intermediate_rounding_clause_e,
+ dspc_options_para_e,
+ dspc_arithmetic_clause_e,
+ dspc_default_rounded_clause_e,
+ dspc_entry_convention_clause_e,
+ dspc_float_binary_clause_e,
+ dspc_float_decimal_clause_e,
+ dspc_initialize_clause_e,
+ dspc_intermediate_rounding_clause_e,
dspc_environment_div_e,
- dspc_configuration_section_e,
- dspc_source_computer_paragraph_e,
+ dspc_configuration_section_e,
+ dspc_source_computer_paragraph_e,
dspc_object_computer_paragraph_e,
-
- dspc_i_o_section_e,
+
+ dspc_i_o_section_e,
// special names clauses
- dspc_special_names_paragraph_e,
- dspc_alphabet_name_clause_e,
+ dspc_special_names_paragraph_e,
+ dspc_alphabet_name_clause_e,
dspc_class_clause_e,
dspc_crt_status_clause_e,
- dspc_currency_sign_clause_e,
+ dspc_currency_sign_clause_e,
dspc_cursor_clause_e,
- dspc_decimal_point_is_comma_clause_e,
- dspc_device_clause_e,
+ dspc_decimal_point_is_comma_clause_e,
+ dspc_device_clause_e,
dspc_dynamic_length_structure_clause_e,
- dspc_feature_clause_e,
- dspc_locale_clause_e,
+ dspc_feature_clause_e,
+ dspc_locale_clause_e,
dspc_order_table_clause_e,
- dspc_switch_clause_e,
- dspc_symbolic_characters_clause_e,
+ dspc_switch_clause_e,
+ dspc_symbolic_characters_clause_e,
- dspc_repository_paragraph_e,
+ dspc_repository_paragraph_e,
dspc_input_output_section_e,
- dspc_file_control_paragraph_e,
- dspc_i_o_control_paragraph_e,
+ dspc_file_control_paragraph_e,
+ dspc_i_o_control_paragraph_e,
dspc_data_div_e, // sorted by alphabetically by section and clause
- dspc_linkage_section_e,
+ dspc_linkage_section_e,
- dspc_file_section_e,
- dspc_local_storage_section_e,
- dspc_report_section_e,
- dspc_screen_section_e,
- dspc_working_storage_section_e,
+ dspc_file_section_e,
+ dspc_local_storage_section_e,
+ dspc_report_section_e,
+ dspc_screen_section_e,
+ dspc_working_storage_section_e,
// not used: parser checks only the Data Division Section.
- dspc_77_level_description_entry_e,
- dspc_constant_entry_e,
- dspc_file_description_entry_e,
- dspc_record_description_entry_e,
- dspc_report_group_description_entry_e,
- dspc_screen_description_entry_e,
- dspc_sort_merge_file_description_entry_e,
- dspc_type_declaration_entry_e,
+ dspc_77_level_description_entry_e,
+ dspc_constant_entry_e,
+ dspc_file_description_entry_e,
+ dspc_record_description_entry_e,
+ dspc_report_group_description_entry_e,
+ dspc_screen_description_entry_e,
+ dspc_sort_merge_file_description_entry_e,
+ dspc_type_declaration_entry_e,
dspc_procedure_div_e,
dspc_procedure_header_e,
@@ -304,15 +304,15 @@ enum symbol_type_t {
SymAlphabet,
SymFile,
SymDataSection,
- SymLocale,
+ SymLocale,
};
// From Enterprise COBOL for z/OS 6.4 Language Reference, Appendix B.
// ISO specifies no limit in 13.18.40.3 Syntax rules.
-// CobolCraft sometimes needs 2,100,000 or about 2 MB.
+// CobolCraft sometimes needs 2,100,000 or about 2 MB.
#ifdef COBOL_MAXIMUM_ALPHA_LENGTH
# define MAXIMUM_ALPHA_LENGTH size_t(COBOL_MAXIMUM_ALPHA_LENGTH)
-#else
+#else
# define IBM_MAXIMUM_ALPHA_LENGTH (size_t(1) << 31)
# define MAXIMUM_ALPHA_LENGTH IBM_MAXIMUM_ALPHA_LENGTH
#endif
@@ -387,7 +387,7 @@ public:
cbl_field_data_t( uint32_t memsize, uint32_t nbyte,
uint32_t digits, uint32_t rdigits,
const char *initial,
- const char *picture = NULL )
+ const char *picture = NULL )
: nbyte(nbyte)
, orig(initial)
, memsize(memsize)
@@ -401,7 +401,7 @@ public:
inline uint32_t capacity( uint32_t size ) { return nbyte = size; }
inline uint32_t capacity() const { return nbyte; }
-
+
inline uint32_t add_capacity( uint32_t size ) { return nbyte += size; }
cbl_field_data_t( const cbl_field_data_t& that ) {
@@ -437,15 +437,15 @@ public:
dbgmsg("%s:%d: type is %s", __func__, __LINE__, etc_type_str());
}
return etc.value;
- }
+ }
tree& operator=( tree v) {
etc_type = value_e;
return etc.value = v;
- }
+ }
tree& operator=(int i) {
etc_type = value_e;
return etc.value = build_int_cst_type(integer_type_node, i);
- }
+ }
tree_code value_type() const {
gcc_assert(etc_type == value_e);
@@ -469,7 +469,7 @@ public:
return INTEGRAL_TYPE_P(node);
}
- // verify is numeric and zero fraction
+ // verify is numeric and zero fraction
std::pair<int64_t, bool> int64_of() const {
if( etc_type == value_e ) {
auto r = TREE_REAL_CST_PTR( value_of() );
@@ -515,7 +515,7 @@ public:
double d;
int n;
int erc = sscanf(input.c_str(), "%lf%n", &d, &n);
-
+
if( erc < 0 || size_t(n) != input.size() ) {
dbgmsg("%s: error: could not interpret '%s' of '%s' as a number",
__func__, initial + n, initial);
@@ -546,7 +546,7 @@ public:
this->orig = orig_t( orig, all );
return this->orig.data;
}
- // Set the computed cce value. Do not impute capacity.
+ // Set the computed cce value. Do not impute capacity.
void original( REAL_VALUE_TYPE value ) {
orig = orig_t(value);
}
@@ -572,7 +572,7 @@ public:
case upsi_e:
etc.upsi_mask = that.etc.upsi_mask;
break;
- }
+ }
return *this;
}
};
@@ -673,7 +673,7 @@ bool __gg__encoding_iconv_valid(
cbl_encoding_t encoding );
bool is_elementary( enum cbl_field_type_t type );
-// These were introduced to discourage the use of
+// These were introduced to discourage the use of
// current_encoding('A') and current_encoding('N')
enum
{
@@ -705,7 +705,7 @@ struct cbl_field_t {
friend bool cobol_national_encoding( const char name[] );
encodings_t alpha, national;
const encodings_t possible_sources[2] = {}, *source = 0;
-
+
default_encodings_t( const encodings_t& alpha,
const std::vector<encodings_t>&
possible_sources )
: alpha(alpha)
@@ -782,10 +782,10 @@ struct cbl_field_t {
std::vector<char> frag(len);
std::transform(picture_fragment, picture_fragment + len,
frag.begin(), ftoupper);
- switch(frag[0]) {
+ switch(frag[0]) {
case 'A': case 'X': case '9':
return set(current_encoding(display_encoding_e));
- case 'N': case 'U':
+ case 'N': case 'U':
if( std::all_of(frag.begin(), frag.end(),
[first = frag[0]]( char ch ) {
return first == ch;
@@ -795,7 +795,7 @@ struct cbl_field_t {
: UTF8_e;
return set(enc);
}
- return false; // They all must be the same.
+ return false; // They all must be the same.
}
gcc_unreachable();
}
@@ -842,7 +842,7 @@ struct cbl_field_t {
cbl_field_t( cbl_field_type_t type, uint64_t attr,
const cbl_field_data_t& data,
- uint32_t level, const cbl_name_t name,
+ uint32_t level, const cbl_name_t name,
const cbl_field_t::codeset_t& codeset )
: offset(0), type(type), usage(FldInvalid), attr(attr)
, parent(0), our_index(0), level(level), codeset(codeset)
@@ -911,7 +911,7 @@ struct cbl_field_t {
data = that.data;
codeset = that.codeset;
-
+
if( ! (is_typedef || that.type == FldClass) ) {
data.initial = NULL;
data = build_zero_cst (float128_type_node);
@@ -1071,8 +1071,8 @@ struct cbl_refer_t {
refmod = that.refmod;
return *this;
}
-
-
+
+
cbl_refer_t duplicate() const {
return cbl_refer_t( field, subscripts, refmod );
}
@@ -1111,7 +1111,7 @@ struct cbl_refer_t {
/*
* An element in the RPN stack for expression evaluation, either an
operation
- * or an operand. A NUL operator indicates an operand.
+ * or an operand. A NUL operator indicates an operand.
*/
struct rpn_t {
char op;
@@ -1398,7 +1398,7 @@ struct parameter_t {
/*
* Map symbol table index of procedure/function to formal parameters.
- * Index may refer to definition or prototype.
+ * Index may refer to definition or prototype.
*/
typedef std::map<size_t, std::vector<parameter_t>> parameter_map;
@@ -1562,7 +1562,7 @@ struct cbl_label_t {
// for parser_op/parser_assign error tracking
struct cbl_compute_error_t *compute_error;
-
+
// for parse_xml processing:
struct cbl_xml_parse_t *xml_parse;
@@ -1650,7 +1650,7 @@ void symbol_temporary_location( const cbl_field_t
*field,
cbl_loc_t symbol_temporary_location( const cbl_field_t *field );
class temporaries_t {
- friend void symbol_temporaries_free();
+ friend void symbol_temporaries_free();
friend void symbol_temporary_location( const cbl_field_t *field,
const cbl_loc_t& loc);
friend cbl_loc_t symbol_temporary_location( const cbl_field_t *field );
@@ -1690,7 +1690,7 @@ class temporaries_t {
return value < that.value;
}
bool terminated() const {
- // Z strings include the NUL terminator.
+ // Z strings include the NUL terminator.
return !is_verbatim && is_quoted && !value.empty() && '\0' ==
value.back();
}
};
@@ -1702,7 +1702,7 @@ class temporaries_t {
fieldmap_t used, freed;
public:
- cbl_field_t * literal( uint32_t len, const char value[],
+ cbl_field_t * literal( uint32_t len, const char value[],
cbl_field_attr_t attr, cbl_encoding_t encoding
);
cbl_field_t * reuse( cbl_field_type_t type );
cbl_field_t * acquire( cbl_field_type_t type, const cbl_name_t name =
nullptr );
@@ -1851,7 +1851,7 @@ struct cbl_locale_t {
/*
* If SELECT name ASSIGN TO DEVICE is used, the index of the special name
is
- * assigned to cbl_file_t::device. The device itself never changes.
+ * assigned to cbl_file_t::device. The device itself never changes.
*/
struct cbl_special_name_t {
int token;
@@ -1868,7 +1868,7 @@ char * hex2numstr( const char text[] );
*
* An alphabet may reference a Special-Names LOCALE, which defines an
encoding
* and a collation (perhaps by default).
- *
+ *
* During Special-Names parsing, an Alphabet may reference an as-yet
undefined
* LOCALE with an as-yet unknown encoding. As a placeholder it inserts a
named,
* undefined cbl_locale_t symbol, which the Alphabet references. If that
@@ -1876,8 +1876,8 @@ char * hex2numstr( const char text[] );
* diagnostic at the end of Special-Names.
*
* For a custom alphabet of single-byte encoding,
cbl_alphabet_t::collation_sequence
- * holds the collation position of each encoded value.
- * If 'A' sorts first (after LOW-VALUE), then collation_sequence['A'] ==
1.
+ * holds the collation position of each encoded value.
+ * If 'A' sorts first (after LOW-VALUE), then collation_sequence['A'] ==
1.
* If the encoding is ASCII, then 'A' is 65 and
collation_sequence[ 65] == 1.
* If the encoding is EBCDIC CP1140, then 'A' is 193 and
collation_sequence[193] == 1.
*/
@@ -2063,7 +2063,7 @@ struct cbl_file_key_t {
memset(name, '\0', sizeof(name));
}
- // Construct a key of length 1 having a single field.
+ // Construct a key of length 1 having a single field.
explicit cbl_file_key_t( size_t field, bool unique = true )
: unique(unique)
, leftmost(0)
@@ -2151,7 +2151,7 @@ struct cbl_file_t {
cbl_refer_t *nline, *footing, *top, *bottom;
linage_t()
: nline(nullptr), footing(nullptr), top(nullptr), bottom(nullptr)
- {}
+ {}
} linage;
int line;
cbl_name_t name;
@@ -2177,7 +2177,7 @@ struct cbl_file_t {
{
memset(name, '\0', sizeof(name));
}
-
+
bool varies() const { return varying_size.min != varying_size.max; }
void assign( special_name_t device ) { this->device =
special_index(device); }
bool validate() const;
@@ -2235,7 +2235,7 @@ struct symbol_elem_t {
cbl_section_t section;
symbol_elem_u() : field() {}
} elem;
-
+
symbol_elem_t() : type(SymField), program(0) {}
explicit symbol_elem_t( symbol_type_t type, size_t program = 0 )
: type(type), program(program)
@@ -2271,7 +2271,7 @@ struct symbol_elem_t {
{
elem.section = section;
}
-
+
protected:
symbol_elem_t& copy_by_type( const symbol_elem_t& that ) {
switch(type) {
@@ -2430,7 +2430,7 @@ const cbl_label_t * symbol_program_local( const char
called[] );
bool redefine_field( cbl_field_t *field );
-const cbl_field_t *
+const cbl_field_t *
symbol_unresolved_file_key( const cbl_file_t * file,
const cbl_name_t key_field_name );
@@ -2507,7 +2507,7 @@ cbl_file_of( const symbol_elem_t *e ) {
}
// does the element part of a prototype ?
-bool is_prototypical( size_t isym );
+bool is_prototypical( size_t isym );
static inline bool
is_program( const symbol_elem_t& e ) {
@@ -2647,15 +2647,15 @@ struct cbl_prog_hier_t {
cbl_label_t label;
program_label_t() : ordinal(0), label() {}
// because std::copy_if:
- // cppcheck-suppress noExplicitConstructor
- program_label_t( const symbol_elem_t& e ) {
+ // cppcheck-suppress noExplicitConstructor
+ program_label_t( const symbol_elem_t& e ) {
assert(is_program(e));
ordinal = symbol_index(&e);
label = e.elem.label;
}
};
std::vector<program_label_t> labels;
-
+
cbl_prog_hier_t();
};
@@ -2864,7 +2864,7 @@ std::pair<std::string, bool> keyword_alias_add(
const std::string& keyword,
const std::string& alias
);
int binary_integer_usage_of( const char name[] );
-
+
void tee_up_empty();
void tee_up_name( const cbl_loc_t& loc, const char name[] );
cbl_namelist_t teed_up_names();
@@ -3024,7 +3024,7 @@ int redefined_token( const cbl_name_t name, int
token );
namespace cdf { extern bool any_cobol_words; }
class current_tokens_t {
class tokenset_t {
- // token_names is initialized from a generated header file.
+ // token_names is initialized from a generated header file.
std::vector<const char *>token_names; // position indicates token
value
std::map <std::string, int> tokens; // aliases
std::set<std::string> cobol_words; // COBOL-WORDS may affect a
word only once.
@@ -3091,7 +3091,7 @@ class current_tokens_t {
dbgmsg("%s:%d: removed as a valid token name: %s", __func__,
__LINE__, name);
return fOK;
}
-
+
bool substitute( const cbl_loc_t& loc,
const cbl_name_t extant, int token, const cbl_name_t
name ) {
return
@@ -3164,7 +3164,7 @@ class current_tokens_t {
error_msg(loc, "EQUATE: %qs is already an alias for %qs",
alias, result.first.c_str());
return false;
- }
+ }
return tokens.equate(loc, token, alias);
}
bool undefine( const cbl_loc_t& loc, const cbl_name_t keyword ) {
@@ -3184,7 +3184,7 @@ class current_tokens_t {
error_msg(loc, "SUBSTITUTE: %qs is already an alias for %qs",
alias, result.first.c_str());
return false;
- }
+ }
dbgmsg("%s:%d: %s (%d) will have alias %s", __func__, __LINE__,
keyword, token, alias);
return tokens.substitute(loc, keyword, token, alias);
@@ -3298,9 +3298,12 @@ 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 );
+char *expand_picture(const char *picture);
+
// ENABLE_HIJACKING allows for code generation to be "hijacked" when the
// 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 6abd9091f75..70122334090 100644
--- a/gcc/cobol/util.cc
+++ b/gcc/cobol/util.cc
@@ -235,33 +235,33 @@ cdf_dictionary() {
// elements permitted in a program or function prototype
static const std::set<dspc_t> prototype_elements {
dspc_identification_div_e,
- dspc_options_para_e,
+ dspc_options_para_e,
////_arithmetic_clause_e, disallowed
- dspc_default_rounded_clause_e,
- dspc_entry_convention_clause_e,
- dspc_float_binary_clause_e,
- dspc_float_decimal_clause_e,
- dspc_initialize_clause_e,
- dspc_intermediate_rounding_clause_e,
+ dspc_default_rounded_clause_e,
+ dspc_entry_convention_clause_e,
+ dspc_float_binary_clause_e,
+ dspc_float_decimal_clause_e,
+ dspc_initialize_clause_e,
+ dspc_intermediate_rounding_clause_e,
dspc_environment_div_e,
- dspc_configuration_section_e,
- dspc_source_computer_paragraph_e,
+ dspc_configuration_section_e,
+ dspc_source_computer_paragraph_e,
////_object_computer_paragraph_e, disallowed
-
+
// permitted special names clauses
- dspc_special_names_paragraph_e,
- dspc_alphabet_name_clause_e,
- dspc_currency_sign_clause_e,
- dspc_decimal_point_is_comma_clause_e,
- dspc_locale_clause_e,
- dspc_symbolic_characters_clause_e,
+ dspc_special_names_paragraph_e,
+ dspc_alphabet_name_clause_e,
+ dspc_currency_sign_clause_e,
+ dspc_decimal_point_is_comma_clause_e,
+ dspc_locale_clause_e,
+ dspc_symbolic_characters_clause_e,
// no i-o section, and we assume no repository paragraph
dspc_data_div_e,
dspc_linkage_section_e,
-
+
dspc_procedure_div_e, // only header is allowed
dspc_procedure_header_e,
};
@@ -270,7 +270,7 @@ bool
cbl_prototype_ok( const cbl_loc_t& loc, size_t iprog, dspc_t clause ) {
bool prototyping = cbl_label_of(symbol_at(iprog))->prototype;
if( prototyping && 0 == prototype_elements.count(clause) ) {
- error_msg( loc, "syntax not allowed for PROTOTYPE" );
+ error_msg( loc, "syntax not allowed for PROTOTYPE" );
return false;
}
return true;
@@ -333,7 +333,7 @@ cdf_file( size_t program, const cbl_name_t name ) {
return cbl_file_of(e);
}
return nullptr;
-}
+}
size_t
cdf_file_index( const cbl_file_t *file ) {
@@ -545,7 +545,7 @@ static char regexmsg[80];
static int
named_constant( const cbl_name_t name ) {
int output = -1;
-
+
auto e = symbol_field( current_program_index(), 0, name );
if( e && e->type == SymField ) {
auto f = cbl_field_of(e);
@@ -583,7 +583,7 @@ repeat_count(const char picture[])
if( (count = named_constant(name)) < 0 ) {
error_msg(yylloc, "not a positive integer constant: %qs: %d",
name, count);
}
- }
+ }
}
if( n == 2 && 0 <= count ) {
@@ -1620,7 +1620,7 @@ cbl_field_t::encode_numeric( const char input[],
cbl_loc_t loc ) {
// The final value will have data.digits + l_rdigits
decimal
// places. Let's scale rvalue to that range, taking into
// account that we already have l_rdigits of those
places.
- tester *=
+ tester *=
get_power_of_ten(data.digits + data.rdigits -
l_rdigits);
// In the case of PPP9999, tester needs to be between 1
and
@@ -1925,14 +1925,23 @@ cbl_field_t::encode_numeric( const char input[],
cbl_loc_t loc ) {
}
else
{
- digits_from_int128(ach, this, char_capacity(), value,
l_rdigits);
+ digits_from_int128(ach,
+ this,
+ data.digits,
+ value,
+ l_rdigits);
// __gg__string_to_numeric_edited operates in ASCII space:
+ char *expanded = expand_picture(data.picture);
+ // By the time you read this, this next statement ought to be
+ // obsolete. See RT issue 3682.
+ expanded[char_capacity()] = '\0';
__gg__string_to_numeric_edited( reinterpret_cast<char
*>(retval),
ach,
data.rdigits,
negative,
- data.picture);
+ expanded);
+ free(expanded);
// So now we convert it to the target encoding:
size_t nbytes;
const char *converted =
__gg__iconverter(DEFAULT_SOURCE_ENCODING,
@@ -2099,17 +2108,17 @@ cbl_field_t::report_invalid_initial_value(const
cbl_loc_t& loc) const {
/*
* This is overspecific: It catches numeric literal VALUE for
all_alpha_e\
* only.
- * The general error is:
+ * The general error is:
* - alphanumeric type
* - data.initial is all spaces (based on PICTURE)
* - data.original() is numeric or data.etc_type == value_e
* - quoted_e clear, of course
- *
+ *
* This happens because VALUE was captured as a cce and stored in
* data.original for encode_numeric. But encode_numeric was never
called
* because it's not a numeric field.
*
- * It is also insufficient. It does not deal with VALUE LENGTH OF.
+ * It is also insufficient. It does not deal with VALUE LENGTH OF.
*/
if( is_alpha_only ) {
charmap_t *charmap = __gg__get_charmap(codeset.encoding);
@@ -2124,13 +2133,13 @@ cbl_field_t::report_invalid_initial_value(const
cbl_loc_t& loc) const {
}
}
}
-
+
if( ! is_alpha_only ) {
error_msg(loc, "alpha-only %s VALUE '%s' contains non-alphabetic
data",
name, fig == zero_value_e? cbl_figconst_str(fig) : orig);
-
+
auto pend = orig + strlen(orig);
- auto p = std::find_if( orig, pend,
+ auto p = std::find_if( orig, pend,
[]( char ch ) { return ! ISALPHA(ch); } );
dbgmsg("%zu nonalpha '%.*s'", pend - p, int(pend - p), p);
}
@@ -2329,10 +2338,10 @@ valid_move( const cbl_refer_t& tgt_ref, const
cbl_refer_t& src_ref )
/*
* 8.4.3.3.3 Syntax rules
- * A refmod may apply to:
+ * A refmod may apply to:
* "a numeric data item of usage display or national that is not
subordinate
* to a strongly-typed group item,"
- *
+ *
* 8.4.3.3.4 General rules
*
* "If the data item referenced by identifier-1 is explicitly or
implicitly
@@ -2662,12 +2671,12 @@ namespace match_proc {
};
void error(const cbl_loc_t& loc,
const tgt_t&tgt,
- const found_t& found) const
+ const found_t& found) const
{
const char *clause = tgt == tgts.first? "" : "THRU ";
assert( 1 != found.n );
const char *status = found.n == 0? "procedure not found" :
"ambiguous reference";
-
+
error_msg(loc, "%s: PERFORM %s%s", status, clause,
tgt.name.c_str());
}
};
@@ -2818,7 +2827,7 @@ namespace match_proc {
if( yydebug && 1 < n ) {
for( const auto& para : matched ) {
fprintf(stderr, "procedures_t::find:%d: ambig: %s of #%lu,
%s\n", __LINE__,
- para.name.c_str(), (unsigned long)para.parent,
+ para.name.c_str(), (unsigned long)para.parent,
para.parent_name().c_str());
}
}
@@ -2836,7 +2845,7 @@ namespace match_proc {
static bool match_any_paragraph( const para_t& para,
const stmt_t::tgt_t& tgt )
{
- assert( tgt.qual.empty() );
+ assert( tgt.qual.empty() );
return para.name == tgt.name;
}
static bool match( const para_t& para,
@@ -2845,7 +2854,7 @@ namespace match_proc {
if( tgt.qual.empty() ) {
return para.parent_name() == tgt.name
|| para.name == tgt.name;
- }
+ }
return para.name == tgt.name
&& para.parent_name() == tgt.qual;
}
@@ -2920,7 +2929,7 @@ namespace match_proc {
}
return nerr == 0;
}
-
+
void statement_add() {
stmts.push_back(prototype);
prototype = stmt_t();
@@ -3456,7 +3465,7 @@ bool cobol_filename( const char *name, ino_t inode )
{
assert(inode != 0);
}
}
-
+
linemap_add(line_table, LC_ENTER, sysp, name, 1);
input_filename_vestige = name;
bool pushed = input_filenames.push( input_file_t(name, inode, 1) );
@@ -3559,7 +3568,7 @@ gcc_location_set( const cbl_loc_t& loc ) {
finish_line = linemap_line_start( line_table, loc.last_line, 80 ),
token_finish = linemap_position_for_column( line_table,
loc.last_column);
token_location = make_location (token_start, token_start,
token_finish);
-
+
if( loc.first_line > first_line_minus_1 ) {
// In order for GDB-COBOL to be able to step through COBOL code
properly,
// it is sometimes necessary for the code at the beginning of a COBOL
@@ -3572,7 +3581,7 @@ gcc_location_set( const cbl_loc_t& loc ) {
token_location_minus_1 = loc_m_1;
loc_m_1 = token_location;
}
-
+
location_dump(__func__, __LINE__, "parser", loc);
}
@@ -3863,7 +3872,7 @@ parse_file( const char filename[] )
#endif
parser_leave_file();
-
+
fclose (yyin);
if( erc ) {
diff --git
a/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_gnu.cob
b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_gnu.cob
new file mode 100644
index 00000000000..55130367fa9
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_gnu.cob
@@ -0,0 +1,15 @@
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do run }
+ *> { dg-options "-dialect gnu" }
+
+ identification division.
+ program-id. prog.
+ procedure division.
+ READY TRACE.
+ para-1.
+ DISPLAY "OK" NO ADVANCING.
+ RESET TRACE.
+ para-2.
+ DISPLAY "OK" NO ADVANCING.
+ GOBACK.
+
diff --git
a/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_ibm.cob
b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_ibm.cob
new file mode 100644
index 00000000000..d7e25d2c256
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_ibm.cob
@@ -0,0 +1,15 @@
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do run }
+ *> { dg-options "-dialect ibm" }
+
+ identification division.
+ program-id. prog.
+ procedure division.
+ READY TRACE.
+ para-1.
+ DISPLAY "OK" NO ADVANCING.
+ RESET TRACE.
+ para-2.
+ DISPLAY "OK" NO ADVANCING.
+ GOBACK.
+
diff --git
a/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_iso.cob
b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_iso.cob
new file mode 100644
index 00000000000..298566180ff
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_iso.cob
@@ -0,0 +1,15 @@
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do run }
+ *> { dg-options "-dialect iso" }
+
+ identification division.
+ program-id. prog.
+ procedure division.
+ READY TRACE.
+ para-1.
+ DISPLAY "OK" NO ADVANCING.
+ RESET TRACE.
+ para-2.
+ DISPLAY "OK" NO ADVANCING.
+ GOBACK.
+
diff --git
a/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_mf.cob
b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_mf.cob
new file mode 100644
index 00000000000..2f88d39f1bc
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/PR126612_-_Ignore_TRACE_-_mf.cob
@@ -0,0 +1,15 @@
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do run }
+ *> { dg-options "-dialect mf" }
+
+ identification division.
+ program-id. prog.
+ procedure division.
+ READY TRACE.
+ para-1.
+ DISPLAY "OK" NO ADVANCING.
+ RESET TRACE.
+ para-2.
+ DISPLAY "OK" NO ADVANCING.
+ GOBACK.
+
diff --git
a/gcc/testsuite/cobol.dg/group2/RT3611_-_BY_CONTENT_LENGTH_OF.cob
b/gcc/testsuite/cobol.dg/group2/RT3611_-_BY_CONTENT_LENGTH_OF.cob
new file mode 100644
index 00000000000..3aec619f30e
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/RT3611_-_BY_CONTENT_LENGTH_OF.cob
@@ -0,0 +1,23 @@
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do compile }
+ *> { dg-options "-dialect ibm" }
+[
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 WS-NAME PIC X(30).
+
+ PROCEDURE DIVISION.
+ CALL "TEST01"
+ USING BY CONTENT LENGTH OF WS-NAME
+ GOBACK.
+ END PROGRAM prog.
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. TEST01.
+ PROCEDURE DIVISION.
+ DISPLAY "OK" NO ADVANCING.
+ GOBACK.
+ END PROGRAM TEST01.
+]
diff --git a/gcc/testsuite/cobol.dg/group2/__define__text_.cob
b/gcc/testsuite/cobol.dg/group2/__define__text_.cob
new file mode 100644
index 00000000000..230af5a531d
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/__define__text_.cob
@@ -0,0 +1,23 @@
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do run }
+ *> { dg-options "-dialect mf" }
+ *> { dg-output-file "group2/__define__text_.out" }
+ identification division.
+ program-id. prog1.
+ >> define defined_text as "Defined text"
+ procedure division.
+ display defined_text
+ call "prog2" using defined_text
+ goback.
+ end program prog1.
+
+ identification division.
+ program-id. prog2.
+ data division.
+ linkage section.
+ 01 display_text pic X ANY LENGTH.
+ procedure division using display_text.
+ display display_text
+ goback.
+ end program prog2.
+
diff --git a/gcc/testsuite/cobol.dg/group2/__define__text_.out
b/gcc/testsuite/cobol.dg/group2/__define__text_.out
new file mode 100644
index 00000000000..1b11a370604
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/__define__text_.out
@@ -0,0 +1,3 @@
+Defined text
+Defined text
+
diff --git a/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.cob
b/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.cob
new file mode 100644
index 00000000000..6e66c69be2d
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.cob
@@ -0,0 +1,10 @@
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do run }
+ *> { dg-output-file "group2/customer_bug_Heuristic_Fail.out" }
+00001 *TITLE 'MRS FIELDS ROLLUP DATA PROGRAM.'
06/07/23
+00002 IDENTIFICATION DIVISION.
GD25000A
+00003 PROGRAM-ID. prog.
LV246
+00005 PROCEDURE DIVISION.
+00006 DISPLAY "OK" NO ADVANCING.
+00007 STOP RUN.
+
diff --git a/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.out
b/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.out
new file mode 100644
index 00000000000..d86bac9de59
--- /dev/null
+++ b/gcc/testsuite/cobol.dg/group2/customer_bug_Heuristic_Fail.out
@@ -0,0 +1 @@
+OK
diff --git a/libgcobol/gmath.cc b/libgcobol/gmath.cc
index baa1214bb84..218d527735a 100644
--- a/libgcobol/gmath.cc
+++ b/libgcobol/gmath.cc
@@ -2167,7 +2167,7 @@ __gg__int128_to_int128_rounded( cbl_round_t rounded,
case prohibited_e:
{
__int128 fpart = value % factor;
- if( fpart != 0 )
+ if( fpart != 0 && compute_error)
{
*compute_error |= compute_error_truncate;
}
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index d6a84efee2a..7291c8fa296 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -2138,12 +2138,11 @@ int128_to_field(cblc_field_t *var,
ach[var->digits] = NULLCH;
// Convert that string according to the PICTURE clause
- size_error |= __gg__string_to_numeric_edited(
- as_chars( location),
- ach,
- target_rdigits,
- is_negative,
- var->picture);
+ __gg__string_to_numeric_edited(as_chars(location),
+ ach,
+ target_rdigits,
+ is_negative,
+ var->picture);
size_t outlength;
const char *converted = __gg__iconverter(
DEFAULT_SOURCE_ENCODING,
@@ -2286,6 +2285,38 @@ int128_to_field(cblc_field_t *var,
}
}
+extern "C"
+int
+__gg__int128_to_ascii_numeric_display(const cblc_field_t *var,
+ unsigned char *location,
+ __int128 value)
+ {
+ bool size_error = false;
+ if( value == 0 && (var->attr & blank_zero_e) )
+ {
+ memset(location, ascii_space, var->capacity);
+ }
+ else
+ {
+ char ach[512];
+ bool is_negative = value < 0;
+
+ // At this point, value is scaled to the target's rdigits
+ size_error |= __gg__binary_to_string_ascii(ach,
+ var->digits,
+ value);
+ ach[var->digits] = NULLCH;
+
+ // Convert that string according to the PICTURE clause
+ __gg__string_to_numeric_edited(as_chars(location),
+ ach,
+ var->rdigits,
+ is_negative,
+ var->picture);
+ }
+ return size_error;
+ }
+
#pragma GCC diagnostic ignored "-Wformat-overflow"
static time_t
diff --git a/libgcobol/valconv.cc b/libgcobol/valconv.cc
index c601bbcc9b9..21e89f437dd 100644
--- a/libgcobol/valconv.cc
+++ b/libgcobol/valconv.cc
@@ -18,6 +18,7 @@
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
@@ -59,15 +60,15 @@
#include "cobol-endian.h"
#include "charmaps.h"
#include "exceptl.h"
-static char
-TOUPPER(char ch)
- {
- if(ch >= 'a' && ch <= 'z' )
- {
- return 'A' + ch - 'a';
- }
- return ch;
- }
+////static char
+////TOUPPER(char ch)
+//// {
+//// if(ch >= 'a' && ch <= 'z' )
+//// {
+//// return 'A' + ch - 'a';
+//// }
+//// return ch;
+//// }
#endif
std::unordered_map<size_t, alphabet_state> __gg__alphabet_states;
@@ -135,117 +136,11 @@ __gg__alphabet_create( cbl_encoding_t encoding,
return;
}
-static int
-expand_picture(char *dest, const char *picture)
- {
- // 'dest' must be of adequate length to hold the expanded picture
string,
- // including any extra characters due to a CURRENCY SIGN expansion.
-
- int ch;
- int prior_ch = NULLCH;
- char *d = dest;
- const char *p = picture;
-
- long repeat;
-
- int currency_symbol = NULLCH;
-
- while( (ch = (*p++ & 0xFF) ) )
- {
- if( ch == ascii_oparen )
- {
- // Pick up the number after the left parenthesis
- char *endchar;
- repeat = strtol(p, &endchar, 10);
-
- // We subtract one because we know that the character just before
- // the parenthesis was already placed in dest
- repeat -= 1;
-
- // Update p to the character after the right parenthesis
- p = endchar + 1;
- while(repeat--)
- {
- *d++ = prior_ch;
- }
- }
- else
- {
- prior_ch = ch;
- *d++ = ch;
- }
-
- if( ! __gg__currency_signs[ch].empty() )
- {
- // We are going to be mapping ch to a string in the final result:
- prior_ch = ch;
- currency_symbol = ch;
- }
- }
-
- size_t dest_length = d-dest;
-
- // We have to take into account the possibility that the currency
symbol
- // mapping might be to a string of more than one character:
-
- if( currency_symbol )
- {
- size_t sign_length = __gg__currency_signs[currency_symbol].size();
- assert(0 < sign_length);
- if( --sign_length )
- {
- char *pcurrency = strchr(dest, currency_symbol);
- assert(pcurrency);
- memmove( pcurrency + sign_length,
- pcurrency,
- dest_length - (pcurrency-dest));
- for(size_t i=0; i<sign_length; i++)
- {
- pcurrency[i] = ascii_B;
- }
- dest_length += sign_length;
- }
- }
-
- return (int)(dest_length);
- }
-
-static int
-Lindex(const char *dest, int length, char ch)
- {
- int retval = -1;
- for(int i=0; i<length; i++)
- {
- if( dest[i] == ch )
- {
- // Finds the leftmost
- retval = i;
- break;
- }
- }
- return retval;
- }
-
-static int
-Rindex(const char *dest, int length, char ch)
- {
- int retval = -1;
- for(int i=0; i<length; i++)
- {
- if( dest[i] == ch )
- {
- // Finds the rightmost
- retval = i;
- }
- }
- return retval;
- }
-
extern "C"
-bool
+void
__gg__string_to_numeric_edited( char * const dest,
const char *source, // In source
characters
- int rdigits,
+ int /*rdigits*/,
int is_negative,
const char *picture)
{
@@ -253,998 +148,461 @@ __gg__string_to_numeric_edited( char * const dest,
// to do this in EBCDIC, too. So, 'source' and 'picture' are assumed
to be
// CP1252
- // We need to expand the picture string. We assume that the caller
left
- // enough room in dest to take the expanded picture string.
+ // It is required that the source string's implied decimal point line
up with
+ // the decimal point specified in the picture.
+
+ // We assume that the caller left enough room in dest to take the
expanded
+ // picture string.
// Note that we do not put on a nul terminator, so if you need one,
it's
- // your job to put it there.
+ // the caller's job to put it there.
- int dlength = expand_picture(dest, picture);
+ // Make a copy of the PICTURE string in the destination space. The
picture
+ // is supposed to be the same length as the char_capacity of the
variable.
+ const int length_s = strlen(source);
+ const int length_d = strlen(picture);
+ memcpy(dest, picture, length_d);
+ /* We have two kinds of floating insertion: currency and sign.
- // We need to treat 'V' as a decimal point in order to handle
- // 01 foo pic 999v999 BLANK WHEN ZERO.
- // The "BLANK WHEN ZERO" turns the field into a numeric-edited type,
but the
- // 'V' is still in the picture string.
+ We have two kinds of zero suppression replacement: the 'Z' character
is
+ replaced with a space, and a '*' character is replaced with a '*'.
- for(int i=0; i<dlength; i++)
- {
- if( dest[i] == ascii_v || dest[i] == ascii_V )
- {
- dest[i] = __gg__decimal_point;
- }
- }
+ Within the leading-zero range of floating insertion, the characters
+ B Z 0 / comma are replaced with space.
- // This is the length of the source string, which is all digits, and
has
- // an implied decimal point at the rdigits place. We assume that any
- // source_period or ascii_V in the picture is in the right place
- const int slength = (int)strlen(source);
+ Within the leading-zero range of zero suppression, those characters
take
+ on the replacement character.
- // As a setting up exercise, let's deal with the possibility of a
CR/DB:
- if( dlength >= 2 )
- {
- // It's a positive number, so we might have to get rid of a CR or DB:
- char ch1 = TOUPPER((unsigned char)dest[dlength-2]);
- char ch2 = TOUPPER((unsigned char)dest[dlength-1]);
- if( (ch1 == ascii_D && ch2 == ascii_B)
- || (ch1 == ascii_C && ch2 == ascii_R) )
- {
- if( !is_negative )
- {
- // Per the spec, because the number is positive, those two
- // characters become blank:
- dest[dlength-2] = ascii_space;
- dest[dlength-1] = ascii_space;
- }
- // Trim the dlength by two to reflect those two positions at the
- // right edge, and from here on out we can ignore them.
- dlength -= 2;
- }
- }
+ We accomplish through two passes of the data. The first pass scans
the
+ 'dest' and replaces any possible digit position with the actual data
from
+ the 'source'. While doing that, it finds the left/right limits for
+ possible floating insertion and possible zero suppression.
+
+ During a second pass, the limits of floating insertion and zero
+ suppression are applied. */
// We need to know if we have a currency picture symbol in this string:
// This is the currency character in the PICTURE
- unsigned char currency_picture = NULLCH;
- const char *currency_sign = NULL; // This is the text we output when
+ unsigned char currency_char = NULLCH;
+ const char *currency_text = NULL; // This is the text we output when
// // encountering the
currency_picture
// // character
- // Note that the currency_picture can be upper- or lower-case, which is
why
- // we can't treat dest[] to toupper. That makes me sad, because I have
- // to do some tests for upper- and lower-case Z, and so on.
- for(int i=0; i<dlength; i++)
- {
- int ch = (unsigned int)dest[i] & 0xFF;
- if( ! __gg__currency_signs[ch].empty() )
- {
- currency_picture = ch;
- currency_sign = __gg__currency_signs[ch].c_str();
- break;
- }
- }
+ // Note that the currency_picture can be upper- or lower-case, and mean
+ // separate things in IBM. In ISO COBOL, the comparison is
case-insensitive.
- // Calculate the position of the decimal point:
- int decimal_point_index = slength - rdigits;
+ // This is the character for a floating sign
+ char sign_char;
- // Find the source position of the leftmost non-zero digit in source
- int nonzero_index;
- for(nonzero_index=0; nonzero_index<slength; nonzero_index++)
- {
- if( source[nonzero_index] != ascii_zero )
- {
- break;
- }
- }
+ // In the following limits, all of the rightmosts are past-the-end
indexes
- bool is_zero = (nonzero_index == slength);
+ int leftmost_currency = -1;
+ int rightmost_currency = -1;
- // Push nonzero_index to the left to account for explicit ascii_nine
- // characters:
- int non_native_zeros = slength - nonzero_index;
+ int leftmost_sign = -1;
+ int rightmost_sign = -1;
- // Count up the number of nines
- int nines = 0;
- for(int i=0; i<dlength; i++)
- {
- if( dest[i] == ascii_nine )
- {
- nines += 1;
- }
- }
- if( nines > non_native_zeros )
- {
- non_native_zeros = nines;
- nonzero_index = slength - non_native_zeros;
- if( nonzero_index < 0 )
- {
- nonzero_index = 0;
- }
- }
- // nonzero_index is now the location of the leftmost digit that we will
- // output as a digit. Everything to its left is a leading zero, and
might
- // get replaced with a floating replacement.
+ int leftmost_asterisk = -1;
+ int rightmost_asterisk = -1;
+ int zeroed_asterisk = 0;
- // We are now in a position to address specific situations:
+ int leftmost_z = -1;
+ int rightmost_z = -1;
+ int zeroed_z = 0;
- // This is the case of leading zero suppression
- if( (strchr(picture, ascii_Z)) || (strchr(picture, ascii_z)) )
- {
- int leftmost_indexA = Lindex(dest, dlength, ascii_Z);
- int leftmost_indexB = Lindex(dest, dlength, ascii_z);
- if( leftmost_indexA == -1 )
- {
- leftmost_indexA = leftmost_indexB;
- }
- if( leftmost_indexB == -1 )
- {
- leftmost_indexB = leftmost_indexA;
- }
+ int leftmost_nonzero = -1;
- int rightmost_indexA = Lindex(dest, dlength, ascii_Z);
- int rightmost_indexB = Lindex(dest, dlength, ascii_z);
- if( rightmost_indexA == -1 )
- {
- rightmost_indexA = leftmost_indexB;
- }
- if( rightmost_indexB == -1 )
+ int decimal_position = -1;
+
+ // This is the first pass. Because the currency
+ int index_s = 0;
+ for(int i=0; i<length_d; i++)
+ {
+ int ch = (unsigned int)dest[i] & 0xFF;
+ if( ! __gg__currency_signs[ch].empty() )
{
- rightmost_indexB = leftmost_indexA;
+ currency_char = ch;
+ currency_text = __gg__currency_signs[ch].c_str();
+ if( leftmost_currency == -1 )
+ {
+ leftmost_currency = i;
+ }
+ else
+ {
+ // This is not the leftmost currency character, so it is where a
digit
+ // goes.
+ dest[i] = source[index_s++];
+ if( leftmost_nonzero == -1 && dest[i] != ascii_zero )
+ {
+ leftmost_nonzero = i;
+ }
+ }
+ rightmost_currency = i+1;
}
-
- int leftmost_index = std::min(leftmost_indexA, leftmost_indexB);
- int rightmost_index = std::max(rightmost_indexA, rightmost_indexB);
-
- // We are doing replacement editing: leading zeroes get replaced with
- // spaces.
- if( is_zero && nines == 0 )
+ if( ch == currency_char )
{
- // Corner case: The value is zero, and all numeric positions
- // are suppressed. The result is all spaces:
- memset(dest, ascii_space, dlength);
+ // We have already handled the currency char.
+ continue;
}
- else
+ switch(ch)
{
- int index_s = slength-1; // Index into source string of digits
- int index_d = dlength-1; // Index into the destination
- bool reworked_string = false;
-
- while(index_d >=0)
+ case ascii_minus:
+ case ascii_plus:
{
- // Pick up the destination character that we will replace:
- char ch_d = dest[index_d];
-
- if( ch_d == currency_picture )
+ if( is_negative )
{
- // We are going to lay down the currency string. Keep
- // in mind that our caller nicely left room for it
- size_t sign_len = strlen(currency_sign);
- while(sign_len > 0)
- {
- dest[index_d--] = currency_sign[--sign_len];
- }
- continue;
- }
-
- char ch_s;
- if( index_s < 0 )
- {
- // I don't think this can happen, but just in case:
- ch_s = ascii_zero;
+ sign_char = ascii_minus;
}
else
{
- ch_s = source[index_s];
- }
-
- if( index_s <= nonzero_index && !reworked_string)
- {
- reworked_string = true;
- // index_s is the location of the leftmost non-zero
- // digit.
-
- // So, we are about to enter the world of leading
- // zeroes.
-
- // The specification says, at this point, that
- // all B 0 / , and . inside the floating string
- // are to be considered part of the floating string:
-
- // So, we edit dest[] to make that true:
- int rlim = rightmost_index > index_d ? index_d :
rightmost_index;
-
- for(int i=leftmost_index; i<rlim; i++)
+ if( ch == ascii_plus )
{
- if( dest[i] == ascii_b
- || dest[i] == ascii_B
- || dest[i] == ascii_slash
- || dest[i] == ascii_zero
- || dest[i] == __gg__decimal_separator )
- {
- dest[i] = ascii_space;
- }
+ sign_char = ascii_plus;
}
- // Any B 0 / , immediately to the right are
- // also part of the floating_character string
-
- for(int i=rlim+1; i<index_d; i++)
+ else
{
- if( !( dest[i] == ascii_b
- || dest[i] == ascii_B
- || dest[i] == ascii_slash
- || dest[i] == ascii_zero
- || dest[i] == __gg__decimal_separator))
- {
- break;
- }
- dest[i] = ascii_space;
+ sign_char = ascii_space;
}
}
+ dest[i] = sign_char;
- if( index_s >= decimal_point_index )
+ if( leftmost_sign == -1 )
{
- // We are to the right of the decimal point, and so we
- // don't do any replacement. We either insert a character,
- // or we replace with a digit:
- switch(ch_d)
- {
- // We are to the right of the decimal point, so Z is
- // a character position
- case ascii_z:
- case ascii_Z:
- case ascii_nine:
- index_s -= 1;
- break;
- case ascii_b:
- case ascii_B:
- ch_s = ascii_space;
- break;
- case ascii_plus:
- if( !is_negative )
- {
- ch_s = ascii_plus;
- }
- else
- {
- ch_s = ascii_minus;
- }
- break;
- case ascii_minus:
- if( !is_negative )
- {
- ch_s = ascii_space;
- }
- else
- {
- ch_s = ascii_minus;
- }
- break;
- case ascii_P:
- case ascii_p:
- // P-scaling has been handled by changing the value
- // and the number of rdigits, so these characters
- // are ignored here:
- break;
- default:
- // Valid possibilities are 0 / ,
- // Just leave them be
- ch_s = ch_d;
- break;
- }
- dest[index_d] = ch_s;
+ leftmost_sign = i;
}
else
{
- // We are to the left of the decimal point:
- if( ch_d == __gg__decimal_point )
+ // This is not the leftmost sign character, so it is where a
digit
+ // goes.
+ dest[i] = source[index_s++];
+ if( leftmost_nonzero == -1 && dest[i] != ascii_zero )
{
- // Do this assignment to handle the situation where
- // period and comma have been swapped. It's necessary
- // because the case statement can't take a variable
- ch_s = __gg__decimal_point;
+ leftmost_nonzero = i;
}
- else
- {
- switch(ch_d)
- {
- case ascii_nine:
- index_s -= 1;
- break;
- case ascii_v:
- case ascii_V:
- ch_s = __gg__decimal_point;
- break;
- case ascii_plus:
- if( !is_negative )
- {
- ch_s = ascii_plus;
- }
- else
- {
- ch_s = ascii_minus;
- }
- break;
- case ascii_minus:
- if( !is_negative )
- {
- ch_s = ascii_space;
- }
- else
- {
- ch_s = ascii_minus;
- }
- break;
-
- case ascii_z:
- case ascii_Z:
- if( index_s < nonzero_index)
- {
- // We are in the leading zeroes, so they are
- // replaced with a space
- ch_s = ascii_space;
- }
- index_s -= 1;
- break;
-
- case ascii_b:
- case ascii_B:
- ch_s = ascii_space;
- break;
-
- default:
- // Valid possibilities are 0 / , which
- // at this point all get replaced with spaces:
- if( index_s < nonzero_index)
- {
- // We are in the leading zeroes, so they are
- // replaced with a space
- ch_s = ascii_space;
- }
- else
- {
- // We still have digits to send out, so the output
- // is a copy of the PICTURE string
- ch_s = ch_d;
- }
- }
- }
- dest[index_d] = ch_s;
}
-
- index_d -= 1;
+ rightmost_sign = i+1;
+ break;
}
- }
- }
-
- // This is the case of leading zero replacement:
- else if( strchr(picture, ascii_asterisk) )
- {
- int leftmost_index = Lindex(dest, dlength, ascii_asterisk);
- int rightmost_index = Rindex(dest, dlength, ascii_asterisk);
- // We are doing replacement editing: leading zeroes get replaced with
- // asterisks, except that any decimal point is put into place:
- if( is_zero && nines == 0 )
- {
- // We need to re-initialize dest, because of the possibility
- // of a CR/DB at the end of the line
- dlength = expand_picture(dest, picture);
- for(int i=0; i<dlength; i++)
- {
- if( dest[i] == ascii_v
- || dest[i] == ascii_V
- || dest[i] == __gg__decimal_point )
- {
- dest[i] = __gg__decimal_point;
- }
- else
+ case ascii_comma:
+ case ascii_period:
+ if( ch == __gg__decimal_point )
{
- dest[i] = ascii_asterisk;
+ decimal_position = i;
}
- }
- }
- else
- {
- int index_s = slength-1; // Index into source string of digits
- int index_d = dlength-1; // Index into the destination
- bool reworked_string = false;
+ break;
- while(index_d >=0)
- {
- // Pick up the destination character that we will replace:
- char ch_d = dest[index_d];
+ case ascii_slash:
+ case ascii_d:
+ case ascii_D:
+ case ascii_b:
+ case ascii_c:
+ case ascii_C:
+ case ascii_r:
+ case ascii_R:
+ case ascii_0:
+ // These are left where they are
+ break;
- if( ch_d == currency_picture )
+ case ascii_B:
+ // This needs some special attention, because a DB at the end is
not
+ // the same as a B on its own at the end.
+ if( i < length_d-1 )
{
- // We are going to lay down the currency string. Keep
- // in mind that our caller nicely left room for it
- size_t sign_len = strlen(currency_sign);
- while(sign_len > 0)
+ dest[i] = ascii_space;
+ }
+ else if( length_d >= 1 )
+ {
+ if( dest[i-1] != ascii_D && dest[i-1] != ascii_d )
{
- dest[index_d--] = currency_sign[--sign_len];
+ // This is an isolated B at the very end of the string
+ dest[i] = ascii_space;
}
- continue;
+ // Otherwise, that final B is part of a DB, and is left alone.
}
+ break;
- char ch_s;
- if( index_s < 0 )
+ case ascii_9:
+ // These are positions that hold digits
+ dest[i] = source[index_s++];
+ if( leftmost_nonzero == -1 && dest[i] != ascii_zero )
{
- // I don't think this can happen, but just in case:
- ch_s = ascii_zero;
+ leftmost_nonzero = i;
}
- else
+ break;
+
+ case ascii_asterisk:
+ // These are positions that hold digits
+ if( leftmost_asterisk == -1 )
{
- ch_s = source[index_s];
+ leftmost_asterisk = i;
}
+ rightmost_asterisk = i+1;
- if( index_s <= nonzero_index && !reworked_string)
+ dest[i] = source[index_s++];
+ if( dest[i] == ascii_zero )
{
- reworked_string = true;
- // index_s is the location of the leftmost non-zero
- // digit.
-
- // So, we are about to enter the world of leading
- // zeroes.
-
- // The specification says, at this point, that
- // all B 0 / , and . inside the floating string
- // are to be considered part of the floating string:
-
- // So, we edit dest[] to make that true:
- int rlim = rightmost_index > index_d ? index_d :
rightmost_index;
-
- for(int i=leftmost_index; i<rlim; i++)
+ zeroed_asterisk += 1;
+ }
+ else
+ {
+ if( leftmost_nonzero == -1 )
{
- if( dest[i] == ascii_b
- || dest[i] == ascii_B
- || dest[i] == ascii_slash
- || dest[i] == ascii_zero
- || dest[i] == __gg__decimal_separator )
- {
- dest[i] = ascii_asterisk;
- }
+ leftmost_nonzero = i;
}
- // Any B 0 / , immediately to the right are
- // also part of the floating_character string
+ }
+ break;
- for(int i=rlim+1; i<index_d; i++)
- {
- if( !( dest[i] == ascii_b
- || dest[i] == ascii_B
- || dest[i] == ascii_slash
- || dest[i] == ascii_zero
- || dest[i] == __gg__decimal_separator))
- {
- break;
- }
- dest[i] = ascii_asterisk;
- }
+ case ascii_Z:
+ // These are positions that hold digits
+ if( leftmost_z == -1 )
+ {
+ leftmost_z = i;
}
+ rightmost_z = i+1;
- if( index_s >= decimal_point_index )
+ dest[i] = source[index_s++];
+ if( dest[i] == ascii_zero )
{
- // We are to the right of the decimal point, and so we
- // don't do any replacement. We either insert a character,
- // or we replace with a digit:
- switch(ch_d)
- {
- // We are to the right of the decimal point, so asterisk
- // is a a character position
- case ascii_asterisk:
- case ascii_nine:
- index_s -= 1;
- break;
- case ascii_b:
- case ascii_B:
- ch_s = ascii_space;
- break;
- case ascii_plus:
- if( !is_negative )
- {
- ch_s = ascii_plus;
- }
- else
- {
- ch_s = ascii_minus;
- }
- break;
- case ascii_minus:
- if( !is_negative )
- {
- ch_s = ascii_space;
- }
- else
- {
- ch_s = ascii_minus;
- }
- break;
- default:
- // Valid possibilities are 0 / ,
- // Just leave them be
- ch_s = ch_d;
- break;
- }
- dest[index_d] = ch_s;
+ zeroed_z += 1;
}
else
{
- // We are to the left of the decimal point:
- if( ch_d == __gg__decimal_point )
- {
- ch_s = __gg__decimal_point;
- }
- else
+ if( leftmost_nonzero == -1 )
{
- switch(ch_d)
- {
- case ascii_nine:
- index_s -= 1;
- break;
- case ascii_v:
- case ascii_V:
- ch_s = __gg__decimal_point;
- break;
- case ascii_plus:
- if( !is_negative )
- {
- ch_s = ascii_plus;
- }
- else
- {
- ch_s = ascii_minus;
- }
- break;
- case ascii_minus:
- if( !is_negative )
- {
- ch_s = ascii_space;
- }
- else
- {
- ch_s = ascii_minus;
- }
- break;
-
- case ascii_asterisk:
- if( index_s < nonzero_index)
- {
- // We are in the leading zeroes, so they are
- // replaced with an asterisk
- ch_s = ascii_asterisk;
- }
- index_s -= 1;
- break;
-
- case ascii_b:
- case ascii_B:
- ch_s = ascii_space;
- break;
-
- default:
- // Valid possibilities are 0 / , which
- // at this point all get replaced with spaces:
- if( index_s < nonzero_index)
- {
- // We are in the leading zeroes, so they are
- // replaced with our suppression character
- ch_s = ascii_asterisk;
- }
- else
- {
- // We still have digits to send out, so the output
- // is a copy of the PICTURE string
- ch_s = ch_d;
- }
- }
+ leftmost_nonzero = i;
}
- dest[index_d] = ch_s;
}
+ break;
- index_d -= 1;
- }
+ default:
+ abort();
}
}
- else
- {
- // At this point, we check for a floating $$, ++, or --
- unsigned char floating_character = 0;
- int leftmost_index;
- int rightmost_index;
-
- leftmost_index = Lindex(dest, dlength, ascii_plus);
- rightmost_index = Rindex(dest, dlength, ascii_plus);
- if( rightmost_index > leftmost_index)
+ // Do currency replacement
+ if( leftmost_currency >= 0 )
+ {
+ if( leftmost_currency == rightmost_currency-1 )
{
- floating_character = ascii_plus;
- goto got_float;
+ // This is a solo currency symbol
+ memcpy(dest + leftmost_currency - (strlen(currency_text)-1),
+ currency_text,
+ strlen(currency_text));
}
-
- leftmost_index = Lindex(dest, dlength, ascii_minus);
- rightmost_index = Rindex(dest, dlength, ascii_minus);
- if( rightmost_index > leftmost_index)
+ else
{
- floating_character = ascii_minus;
- goto got_float;
+ // This is a floating currency symbol. We need to start at
+ // leftmost_currency, and walk to the lesser of rightmost_currency
and
+ // leftmost_nonzero. We blank every character we encounter.
+ int left = leftmost_currency;
+ int right;
+ if( leftmost_nonzero >= 0 )
+ {
+ right = std::min(leftmost_nonzero, rightmost_currency);
+ if( decimal_position >= 0 )
+ {
+ right = std::min(right, decimal_position);
+ }
+ }
+ else
+ {
+ right = rightmost_currency;
+ }
+ // blank out that range
+ memset(dest+left, ascii_space, right-left);
+
+ // To handle situations like PIC $$$,999, where the currency sign
has to
+ // overwrite the comma, we walk from here until we hit the column
just to
+ // the left of a digit
+ while( right < length_d )
+ {
+ if( (dest[right] >= ascii_zero && dest[right] <= ascii_nine)
+ || right == decimal_position )
+ {
+ break;
+ }
+ dest[right] = ascii_space;
+ right += 1;
+ }
+ if( right < length_d )
+ {
+ right -= 1;
+ memcpy(dest + right - (strlen(currency_text)-1),
+ currency_text,
+ strlen(currency_text));
+ }
}
+ }
- leftmost_index = Lindex(dest, dlength, currency_picture);
- rightmost_index = Rindex(dest, dlength, currency_picture);
- if( rightmost_index > leftmost_index)
+ // Do sign replacement
+ if( leftmost_sign >= 0 )
+ {
+ if( leftmost_sign == rightmost_sign-1 )
{
- floating_character = currency_picture;
- goto got_float;
+ // This is a solo sign symbol
+ dest[leftmost_sign] = sign_char;
}
-got_float:
-
- if( floating_character )
+ else
{
- if( is_zero && nines == 0 )
+ // This is a floating sign symbol. We need to start at
+ // leftmost_sign, and walk to the lesser of rightmost_sign and
+ // leftmost_nonzero. We blank every character we encounter.
+ int left = leftmost_sign;
+ int right;
+ if( leftmost_nonzero >= 0 )
{
- // Special case:
- memset(dest, ascii_space, dlength);
+ right = std::min(leftmost_nonzero, rightmost_sign);
+ if( decimal_position >= 0 )
+ {
+ right = std::min(right, decimal_position);
+ }
}
else
{
- const char *decimal_location = strchr(dest, __gg__decimal_point);
- if( !decimal_location )
- {
- decimal_location = strchr(dest, ascii_v);
- }
- if( !decimal_location )
- {
- decimal_location = strchr(dest, ascii_V);
- }
- if( !decimal_location )
- {
- decimal_location = dest + dlength;
- }
- int decimal_index = (int)(decimal_location - dest);
+ right = rightmost_sign;
+ }
+ // blank out that range
+ memset(dest+left, ascii_space, right-left);
- if( rightmost_index > decimal_index )
+ // To handle situations like PIC $$$,999, where the sign char has
to
+ // overwrite the comma, we walk from here until we hit the column
just to
+ // the left of a digit
+ while( right < length_d )
+ {
+ if( (dest[right] >= ascii_zero && dest[right] <= ascii_nine)
+ || right == decimal_position )
{
- rightmost_index = decimal_index -1;
+ break;
}
+ dest[right] = ascii_space;
+ right += 1;
+ }
+ if( right < length_d )
+ {
+ right -= 1;
+ dest[right] = sign_char;
+ }
+ }
+ }
- int index_s = slength-1; // Index into source string of digits
- int index_d = dlength-1; // Index into the destination
- bool in_float_string = false;
- bool reworked_string = false;
-
- while(index_d >=0)
- {
- // Pick up the destination character that we will replace:
- unsigned char ch_d = dest[index_d];
- char ch_s = ascii_caret; // Flag this as being replaced
+ // Do '*' zero suppression
+ if( leftmost_asterisk >= 0 )
+ {
+ // This is a floating zero suppression.
- if( index_d == leftmost_index )
- {
- // At this point ch_d is the leftmost floating_character,
- // which means it *must* go into the output stream,
- // and that means we are truncating any remaining input.
-
- // Setting nonzero_index to be one character to the right
- // means that the following logic will think that any
- // source characters from here on out are zeroes
- nonzero_index = index_s+1;
- }
+ int left = leftmost_asterisk;
+ int right;
+ if( leftmost_nonzero >= 0 )
+ {
+ // The value being formatted is non-zero, so make sure 'right' is
no more
+ // than the decimal position.
+ right = std::min(leftmost_nonzero, rightmost_asterisk);
+ if( decimal_position >= 0 && decimal_position > leftmost_asterisk )
+ {
+ right = std::min(right, decimal_position);
+ }
+ }
+ else
+ {
+ // The value being formatted is zero
+ if( zeroed_asterisk == length_s )
+ {
+ // Every numeric position was a zero on asterisk, so the whole
thing
+ // is starred.
+ left = 0;
+ right = length_d;
+ }
+ else
+ {
+ right = rightmost_asterisk;
+ }
+ }
+ // blank out that range
+ memset(dest+left, ascii_asterisk, right-left);
- if( ch_d != floating_character && ch_d == currency_picture )
- {
- // This is a non-floating currency_picture characger
- // We are going to lay down the currency string. Keep
- // in mind that our caller nicely left room for it
- size_t sign_len = strlen(currency_sign);
- while(sign_len > 0)
- {
- dest[index_d--] = currency_sign[--sign_len];
- }
- continue;
- }
- if( ch_d != floating_character && ch_d == ascii_plus )
- {
- // This is a non-floating plus sign
- if( !is_negative )
- {
- ch_s = ascii_plus;
- }
- else
- {
- ch_s = ascii_minus;
- }
- dest[index_d--] = ch_s;
- continue;
- }
- if( ch_d != floating_character && ch_d == ascii_minus )
- {
- // This is a non-floating minus sign
- if( !is_negative )
- {
- ch_s = ascii_space;
- }
- else
- {
- ch_s = ascii_minus;
- }
- dest[index_d--] = ch_s;
- continue;
- }
+ // To handle situations like PIC ZZZ,999, where the suppression char
has to
+ // overwrite the comma, we walk from here until we hit the column
just to
+ // the left of a digit
+ while( right < length_d )
+ {
+ if( (dest[right] >= ascii_zero && dest[right] <= ascii_nine)
+ || right == decimal_position )
+ {
+ break;
+ }
+ dest[right] = ascii_asterisk;
+ right += 1;
+ }
+ // One final fillip: The nature of '*' zero suppression is that the
+ // decimal point is always visible. Sending zero to ***,***.**
results in
+ // "*******.***"
+ if( decimal_position >= 0 )
+ {
+ dest[decimal_position] = __gg__decimal_point;
+ }
+ }
- if( index_s < 0 )
- {
- // I don't think this can happen, but just in case:
- ch_s = ascii_zero;
- }
- else
- {
- ch_s = source[index_s];
- if( index_s <= nonzero_index && !reworked_string)
- {
- reworked_string = true;
- // index_s is the location of the leftmost non-zero
- // digit.
-
- // So, we are about to enter the world of leading
- // zeroes.
-
- // The specification says, at this point, that
- // all B 0 / , and . inside the floating string
- // are to be considered part of the floating string:
-
- // So, we edit dest[] to make that true:
- int rlim = rightmost_index > index_d ? index_d :
rightmost_index;
-
- for(int i=leftmost_index; i<rlim; i++)
- {
- if( dest[i] == ascii_b
- || dest[i] == ascii_B
- || dest[i] == ascii_slash
- || dest[i] == ascii_zero
- || dest[i] == __gg__decimal_separator
- || dest[i] == __gg__decimal_point )
- {
- dest[i] = floating_character;
- }
- }
- // Any B 0 / , immediately to the right are
- // also part of the floating_character string
-
- for(int i=rlim+1; i<index_d; i++)
- {
- if( !( dest[i] == ascii_b
- || dest[i] == ascii_B
- || dest[i] == ascii_slash
- || dest[i] == ascii_zero
- || dest[i] == __gg__decimal_separator))
- {
- break;
- }
- dest[i] = floating_character;
- }
- }
- }
- if( index_s >= decimal_point_index )
- {
- // We are to the right of the decimal point, and so we
- // don't do any replacement. We either insert a character,
- // or we replace with a digit:
- switch(ch_d)
- {
- case ascii_nine:
- index_s -= 1;
- break;
- case ascii_b:
- case ascii_B:
- ch_s = ascii_space;
- break;
- default:
- if( ch_d == floating_character )
- {
- // We are laying down a digit
- index_s -= 1;
- }
- else
- {
- // Valid possibilities are 0 / ,
- // Just leave them be
- ch_s = ch_d;
- }
- break;
- }
- dest[index_d] = ch_s;
- }
- else
- {
- // We are to the left of the decimal point:
-
- if( ch_d == __gg__decimal_point )
- {
- ch_s = __gg__decimal_point;
- }
- else if (ch_d == floating_character)
- {
- if( index_s < nonzero_index )
- {
- // We are in the leading zeroes.
- if( !in_float_string )
- {
- in_float_string = true;
- // We have arrived at the rightmost floating
- // character in the leading zeroes
-
- if( floating_character == currency_picture )
- {
- size_t sign_len = strlen(currency_sign);
- while(sign_len > 0)
- {
- dest[index_d--] = currency_sign[--sign_len];
- }
- continue;
- }
- if( floating_character == ascii_plus )
- {
- if( !is_negative )
- {
- ch_s = ascii_plus;
- }
- else
- {
- ch_s = ascii_minus;
- }
- dest[index_d--] = ch_s;
- continue;
- }
- if( floating_character == ascii_minus )
- {
- if( !is_negative )
- {
- ch_s = ascii_space;
- }
- else
- {
- ch_s = ascii_minus;
- }
- dest[index_d--] = ch_s;
- continue;
- }
- }
- else
- {
- // We are in the leading zeros and the
- // floating character location is to our
- // right. So, we put down a space:
- dest[index_d--] = ascii_space;
- continue;
- }
- }
- else
- {
- // We hit a floating character, but we aren't
- // yet in the leading zeroes
- index_s -= 1;
- dest[index_d--] = ch_s;
- continue;
- }
- }
-
- if( ch_d == __gg__decimal_point)
- {
- ch_s = __gg__decimal_point;
- }
- else
- {
- switch(ch_d)
- {
- case ascii_nine:
- index_s -= 1;
- break;
- case ascii_v:
- case ascii_V:
- ch_s = __gg__decimal_point;
- break;
- case ascii_b:
- case ascii_B:
- ch_s = ascii_space;
- break;
-
- default:
- // Valid possibilities are 0 / , which
- // at this point all get replaced with spaces:
- if( index_s < nonzero_index)
- {
- // We are in the leading zeroes, so they are
- // replaced with our suppression character
- ch_s = ascii_space;
- }
- else
- {
- // We still have digits to send out, so the output
- // is a copy of the PICTURE string
- ch_s = ch_d;
- }
- }
- }
- dest[index_d] = ch_s;
- }
+ // Do 'Z' zero suppression
+ if( leftmost_z >= 0 )
+ {
+ // This is a floating zero suppression.
- index_d -= 1;
- }
+ int left = leftmost_z;
+ int right;
+ if( leftmost_nonzero >= 0 )
+ {
+ // The value being formatted is non-zero, so make sure 'right' is
no more
+ // than the decimal position.
+ right = std::min(leftmost_nonzero, rightmost_z);
+ if( decimal_position >= 0 && decimal_position > leftmost_asterisk )
+ {
+ right = std::min(right, decimal_position);
}
}
else
{
- // Simple replacement editing
- int index_s = slength-1; // Index into source string of digits
- int index_d = dlength-1; // Index into the destination
-
- while(index_d >=0)
+ if( zeroed_z == length_s )
{
- // Pick up the destination character that we will replace:
- char ch_d = dest[index_d];
-
- if( ch_d == currency_picture )
- {
- // We are going to lay down the currency string. Keep
- // in mind that our caller nicely left room for it
- size_t sign_len = strlen(currency_sign);
- while(sign_len > 0)
- {
- dest[index_d--] = currency_sign[--sign_len];
- }
- continue;
- }
+ // Every numeric position was a zero on asterisk, so the whole
thing
+ // is blanked.
+ left = 0;
+ right = length_d;
+ }
+ else
+ {
+ right = rightmost_z;
+ }
+ }
+ // blank out that range
+ memset(dest+left, ascii_space, right-left);
- char ch_s;
- if( index_s < 0 )
- {
- // I don't think this can happen, but just in case:
- ch_s = ascii_zero;
- }
- else
- {
- ch_s = source[index_s];
- }
- switch(ch_d)
- {
- // We are to the right of the decimal point, so Z is
- // a character position
- case ascii_nine:
- index_s -= 1;
- break;
- case ascii_b:
- case ascii_B:
- ch_s = ascii_space;
- break;
- case ascii_plus:
- if( !is_negative )
- {
- ch_s = ascii_plus;
- }
- else
- {
- ch_s = ascii_minus;
- }
- break;
- case ascii_minus:
- if( !is_negative )
- {
- ch_s = ascii_space;
- }
- else
- {
- ch_s = ascii_minus;
- }
- break;
- default:
- // Valid possibilities are 0 / ,
- // Just leave whatever is here alone
- ch_s = ch_d;
- break;
- }
- dest[index_d--] = ch_s;
+ // To handle situations like PIC ZZZ,999, where the suppression char
has to
+ // overwrite the comma, we walk from here until we hit the column
just to
+ // the left of a digit
+ while( right < length_d )
+ {
+ if( (dest[right] >= ascii_zero && dest[right] <= ascii_nine)
+ || right == decimal_position )
+ {
+ break;
}
+ dest[right] = ascii_space;
+ right += 1;
}
}
- bool retval = false;
- return retval;
+ // Any final DB/CR needs to be addressed:
+ if( !is_negative
+ && length_d >= 2
+ && ( dest[length_d-2] == ascii_D
+ || dest[length_d-2] == ascii_d
+ || dest[length_d-2] == ascii_C
+ || dest[length_d-2] == ascii_c ) )
+ {
+ dest[length_d-2] = dest[length_d-1] = ascii_space;
+ }
+
+ return;
}
extern "C"
@@ -1266,7 +624,8 @@ __gg__string_to_alpha_edited( char *dest,
charmap_t *charmap_dest = __gg__get_charmap(dest_encoding);
- int destlength = expand_picture(dest, picture);
+ int destlength = strlen(picture);
+ memcpy(dest, picture, destlength);
int dindex = 0;
int sindex = 0;
@@ -1307,10 +666,10 @@ __gg__string_to_alpha_edited( char *dest,
dindex += 1;
}
}
-
+
extern "C"
void
-__gg__currency_sign_init() // This duplicates the constructor.
+__gg__currency_sign_init() // This duplicates the constructor.
{
for( auto str : __gg__currency_signs ) {
str.clear();
diff --git a/libgcobol/valconv.h b/libgcobol/valconv.h
index d9c4b11a44a..62ee342c2b0 100644
--- a/libgcobol/valconv.h
+++ b/libgcobol/valconv.h
@@ -53,7 +53,7 @@ extern "C"
const unsigned char *alphabet,
int low_char,
int high_char );
- bool __gg__string_to_numeric_edited(char * const dest,
+ void __gg__string_to_numeric_edited(char * const dest,
const char *source, // ASCII
int rdigits,
int is_negative,
--
2.34.1
