From: Robert Dubner <[email protected]>
Date: Mon, 21 Sep 2026 13:03:11 -0400
Subject: [PATCH] cobol: Improve speed of numeric-edited formatting.
The speed of converting numerical strings to numeric-edited variables
has been improved by moving run-time PICTURE processing to compile time.
gcc/cobol/ChangeLog:
* genapi.cc (actually_create_the_static_field): Use the
new expand_expanded routine.
* symbols.cc (expand_picture): Add space to accommodate the six
additional pre-processing characters.
(expand_expanded): Append compile-time data to the end of numeric-
edited PICTURE strings.
* symbols.h (redefined_token): Formatting.
(class current_tokens_t): Formatting.
(expand_expanded): New declaration.
* util.cc (cbl_field_t::encode_numeric): Use expand_expanded().
libgcobol/ChangeLog:
* libgcobol.cc (int128_to_field): Remove rdigits formal parameter.
(__gg__int128_to_ascii_numeric_display): Likewise.
* valconv.cc (__gg__string_to_numeric_edited): Complete rewrite to
use parameters appended by expand_expanded().
* valconv.h: Remove rdigits format parameter from
__gg__int128_to_ascii_numeric_display.
gcc/testsuite/ChangeLog:
*
cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_functions_0_and_2
_.cob: New test.
*
cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_functions_0_and_2
_.out: New test.
---
gcc/cobol/genapi.cc | 5 +
gcc/cobol/symbols.cc | 223 ++++++++++
gcc/cobol/symbols.h | 22 +-
gcc/cobol/util.cc | 5 +-
..._get_program_name_-_functions_0_and_2_.cob | 71 ++++
..._get_program_name_-_functions_0_and_2_.out | 3 +
libgcobol/libgcobol.cc | 8 +-
libgcobol/valconv.cc | 390 +++++++-----------
libgcobol/valconv.h | 1 -
9 files changed, 466 insertions(+), 262 deletions(-)
create mode 100644
gcc/testsuite/cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_fun
ctions_0_and_2_.cob
create mode 100644
gcc/testsuite/cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_fun
ctions_0_and_2_.out
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index 5d7d553b9d8..e3753fd7709 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -14431,7 +14431,12 @@ 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);
+
char *expanded = expand_picture(new_var->data.picture);
+ if( new_var->type == FldNumericEdited )
+ {
+ expand_expanded(expanded);
+ }
tree picture = gg_string_literal(expanded);
free(expanded);
tree initial;
diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc
index 6d96ba311b6..c41e0b8ff2a 100644
--- a/gcc/cobol/symbols.cc
+++ b/gcc/cobol/symbols.cc
@@ -4798,6 +4798,12 @@ 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;
+
+ // In the expand_expanded routine, we are going to tack on some
additional
+ // characters in order to speed up compile-time processin.
+ static const int PICTURE_EXTRA = 6;
+ retval_length += PICTURE_EXTRA;
+
char *retval = static_cast<char *>(xmalloc(retval_length));
int ch;
@@ -4909,9 +4915,226 @@ expand_picture(const char *picture)
break;
}
}
+
+ // AD HOC FIX for an improper trailing space
+ char *pspace = strchr(retval, ascii_space);
+ if( pspace )
+ {
+ *pspace = NULLCH;
+ }
+
return retval;
}
+void
+expand_expanded(char *expanded)
+ {
+ if(strlen(expanded) == 0)
+ {
+ return;
+ }
+
+ unsigned char *dest = reinterpret_cast<unsigned char *>(expanded);
+
+ /* In order to make __gg__string_to_numeric_edited() run quickly, we
are
+ going to process the expanded picture string especially for it.
What we
+ do here:
+
+ Convert B to space, taking care not to touch a final 'DB'
+
+ Find the currency picture symbol
+
+ Find the span of any '$$', '++', '--' 'Z', and '*' runs.
+
+ For any '$$', '++' and '--' runs, replace the first such char with a
+ space, and all the others with '9'
+
+ For any 'Z' and '*' runs, replace all the characters with '9'.
+
+ Figure out if any of the original picture characters are '9'.
+
+ That information gets encoded into six characters that are appended
to
+ the modified string.
+
+ Offset 0: The currency character
+ Offset 1: The floating character (space if empty)
+ Offset 2-3: The starting index of the float.
+ Offset 3-4: The one-past-the-end index of the float.
+
+ When there are '9' characters in the original, the 0x40 bit of
offset 2
+ is turned on, turning '0'-'9' into 'q'-'y'
+
+ Is everybody ready? Then we'll begin. */
+
+ int length_d = strlen(expanded);
+
+ unsigned char currency_char = ascii_space;
+ // 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.
+
+ unsigned floating_char = ascii_space;
+ int leftmost_float = -1;
+ int rightmost_float = -1; // This is a one-past-the-end index
+
+ bool got_nines = false;
+
+ for(int i=0; i<length_d; i++)
+ {
+ int ch = (unsigned int)dest[i] & 0xFF;
+ if( !__gg__currency_signs[ch].empty() )
+ {
+ currency_char = ch;
+ break;
+ }
+ }
+
+ for(int i=0; i<length_d; i++)
+ {
+ if( dest[i] == ascii_9 )
+ {
+ got_nines = true;
+ break;
+ }
+ }
+
+ if( dest[0] == ascii_B )
+ {
+ dest[0] = ascii_space;
+ }
+ for(int i=1; i<length_d; i++)
+ {
+ if( dest[i] == ascii_B && dest[i-1] != ascii_D && dest[i-1] !=
ascii_d )
+ {
+ dest[i] = ascii_space;
+ }
+ }
+
+ if( currency_char != ascii_space )
+ {
+ leftmost_float =
+ static_cast<unsigned char *>(memchr(dest, currency_char, length_d))
- dest;
+ rightmost_float =
+ static_cast<unsigned char *>(memrchr(dest, currency_char,
length_d)) - dest + 1;
+ if( rightmost_float > leftmost_float+1 )
+ {
+ floating_char = currency_char;
+ // Turn the first floating character into a space
+ dest[leftmost_float] = ascii_space;
+ for(int i=leftmost_float+1; i<rightmost_float; i++)
+ {
+ // Of the remainder, turn all floating characters into '9', so
that
+ // they will be filled with numerical data from 'source'.
+ if( dest[i] == floating_char )
+ {
+ dest[i] = ascii_9;
+ }
+ }
+ }
+ else
+ {
+ leftmost_float = rightmost_float = -1;
+ }
+ }
+
+ if( memchr(dest, ascii_minus, length_d) )
+ {
+ int leftmost =
+ static_cast<unsigned char *>(memchr(dest, ascii_minus, length_d)) -
dest;
+ int rightmost =
+ static_cast<unsigned char *>(memrchr(dest, ascii_minus, length_d))
- dest + 1;
+ if( rightmost > leftmost+1 )
+ {
+ floating_char = ascii_minus;
+ leftmost_float = leftmost;
+ rightmost_float = rightmost;
+ for(int i=leftmost_float+1; i<rightmost_float; i++)
+ {
+ // Of the remainder, turn all floating characters into '9', so
that
+ // they will be filled with numerical data from 'source'.
+ if( dest[i] == floating_char )
+ {
+ dest[i] = ascii_9;
+ }
+ }
+ }
+ }
+
+ if( memchr(dest, ascii_plus, length_d) )
+ {
+ int leftmost =
+ static_cast<unsigned char *>(memchr(dest, ascii_plus, length_d)) -
dest;
+ int rightmost =
+ static_cast<unsigned char *>(memrchr(dest, ascii_plus, length_d)) -
dest + 1;
+ if( rightmost > leftmost+1 )
+ {
+ floating_char = ascii_plus;
+ leftmost_float = leftmost;
+ rightmost_float = rightmost;
+ for(int i=leftmost_float+1; i<rightmost_float; i++)
+ {
+ // Of the remainder, turn all floating characters into '9', so
that
+ // they will be filled with numerical data from 'source'.
+ if( dest[i] == floating_char )
+ {
+ dest[i] = ascii_9;
+ }
+ }
+ }
+ }
+
+ if( memchr(dest, ascii_asterisk, length_d) )
+ {
+ floating_char = ascii_asterisk;
+ leftmost_float =
+ static_cast<unsigned char *>(memchr(dest, ascii_asterisk,
length_d)) - dest;
+ rightmost_float =
+ static_cast<unsigned char *>(memrchr(dest, ascii_asterisk,
length_d)) - dest + 1;
+ for(int i=leftmost_float; i<rightmost_float; i++)
+ {
+ // Turn all floating characters into '9', so that
+ // they will be filled with numerical data from 'source'.
+ if( dest[i] == floating_char )
+ {
+ dest[i] = ascii_9;
+ }
+ }
+ }
+
+ if( memchr(dest, ascii_Z, length_d) )
+ {
+ floating_char = ascii_Z;
+ leftmost_float =
+ static_cast<unsigned char *>(memchr(dest, ascii_Z, length_d)) -
dest;
+ rightmost_float =
+ static_cast<unsigned char *>(memrchr(dest, ascii_Z, length_d)) -
dest + 1;
+ for(int i=leftmost_float; i<rightmost_float; i++)
+ {
+ // Turn all floating characters into '9', so that
+ // they will be filled with numerical data from 'source'.
+ if( dest[i] == floating_char )
+ {
+ dest[i] = ascii_9;
+ }
+ }
+ }
+
+ char extra[7] = " ";
+ extra[0] = currency_char;
+ if( floating_char != ascii_space )
+ {
+ extra[1] = floating_char;
+ extra[2] = leftmost_float / 10 + ascii_0;
+ extra[3] = leftmost_float % 10 + ascii_0;
+ extra[4] = rightmost_float / 10 + ascii_0;
+ extra[5] = rightmost_float % 10 + ascii_0;
+ if( got_nines )
+ {
+ extra[2] |= 0x40;
+ }
+ }
+ strcat(expanded, extra);
+ }
+
int
length_of_picture(const char *picture)
{
diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h
index 3887b275b7b..d1864b1fdde 100644
--- a/gcc/cobol/symbols.h
+++ b/gcc/cobol/symbols.h
@@ -46,6 +46,7 @@
#include <string>
#include <vector>
+// The ISO spec says there is a
#define PICTURE_MAX 64
extern const char *numed_message;
@@ -2970,7 +2971,7 @@ int redefined_token( const cbl_name_t name, int
token );
* intrinsic functions.
*
* tokens and token_names are defined in a token_names.h, generated from
parse.h.
- *
+ *
* - token_names converts a yytokentype enum to a string form of
* its name as defined in the parser. It is used by keyword_str.
* - tokens imperfectly maps a lowercase form of the token name to its
value.
@@ -2981,16 +2982,16 @@ int redefined_token( const cbl_name_t name, int
token );
* EQUATE adds a new name for a token in tokens.
* UNDEFINE removes a name from tokens.
* SUBSTITUTE is EQUATE for the first name and UNDEFINE for the second.
- * RESERVE adds a new name to tokens with the invalid value -42.
+ * RESERVE adds a new name to tokens with the invalid value -42.
*
* The generated lexer of course uses static strings and is thus
unaffected by
* COBOL-WORDS. The parser accesses the generated lexer via a mediation
layer
* that deals with the CDF. That is where COBOL-WORDS are applied.
*
- * There are unsolved problems.
- * 1. Some tokens are lexed as more than one text word, or depend on
context.
- * For example OBJECT COMPUTER and IDENTIFICATION DIVISION. If the
user
- * substitutes COMPUTING-MACHINE COMPUTER, lexing will fail.
+ * There are unsolved problems.
+ * 1. Some tokens are lexed as more than one text word, or depend on
context.
+ * For example OBJECT COMPUTER and IDENTIFICATION DIVISION. If the
user
+ * substitutes COMPUTING-MACHINE COMPUTER, lexing will fail.
* 2. Semantic values are known only to the lexer. Some tokens carry a
value
* representing their context. For example, both INVALID and NOT
INVALID
@@ -3000,7 +3001,7 @@ int redefined_token( const cbl_name_t name, int
token );
* assign it the value "BOGUS". When that string is found by
* redefined_token and mapped to INVALID (so the parser can parse
it) the
* semantic value is lost.
- *
+ *
* 3. Some names are not NAME tokens, depending on context. That
subtlety is
* also lost.
*
@@ -3105,7 +3106,7 @@ class current_tokens_t {
return true;
}
/*
- * name may be:
+ * name may be:
* 1. just a name, return the input token.
* 2. reserved with -42 token
* 3. a user-defined substitute or alias for a token
@@ -3144,7 +3145,7 @@ class current_tokens_t {
return tokens.find(name, include_intrinsics);
}
bool equate( const cbl_loc_t& loc, const cbl_name_t keyword, const
cbl_name_t alias ) {
- int token;
+ int token;
if( 0 == (token = keyword_tok(keyword, true)) ) {
if( 0 == (token = binary_integer_usage_of(keyword)) ) {
@@ -3165,7 +3166,7 @@ class current_tokens_t {
return tokens.undefine(loc, keyword);
}
bool substitute( const cbl_loc_t& loc, const cbl_name_t keyword, const
cbl_name_t alias ) {
- int token;
+ int token;
if( 0 == (token = keyword_tok(keyword, true)) ) {
if( 0 == (token = binary_integer_usage_of(keyword)) ) {
error_msg(loc, "SUBSTITUTE: not a reserved word: %qs", keyword);
@@ -3293,6 +3294,7 @@ cbl_field_t *new_alphanumeric(const cbl_name_t
name=nullptr,
cbl_encoding_t encoding=no_encoding_e );
char *expand_picture(const char *picture);
+void expand_expanded(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.
diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc
index 70122334090..e4525225981 100644
--- a/gcc/cobol/util.cc
+++ b/gcc/cobol/util.cc
@@ -1936,9 +1936,12 @@ cbl_field_t::encode_numeric( const char input[],
cbl_loc_t loc ) {
// By the time you read this, this next statement ought to be
// obsolete. See RT issue 3682.
expanded[char_capacity()] = '\0';
+ if( type == FldNumericEdited )
+ {
+ expand_expanded(expanded);
+ }
__gg__string_to_numeric_edited( reinterpret_cast<char
*>(retval),
ach,
- data.rdigits,
negative,
expanded);
free(expanded);
diff --git
a/gcc/testsuite/cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_f
unctions_0_and_2_.cob
b/gcc/testsuite/cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_f
unctions_0_and_2_.cob
new file mode 100644
index 00000000000..5b2f160397e
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_f
unctions_0_and_2_.cob
@@ -0,0 +1,71 @@
+ *> Do not edit this generated file. See README.txt
+ *> { dg-do run }
+ *> { dg-options "-dialect mf" }
+ *> { dg-output-file
"group2/CBL_GET_PROGRAM_INFO__get_program_name_-_functions_0_and_2_.out" }
+
+ copy "cblproto.cpy".
+ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ copy "cbltypes.cpy".
+ 01 param-block type cblt-prog-info-params value zeros.
+ 77 fn pic x(4) comp-5.
+ 77 status-code pic x(2) comp-5.
+ 77 buf pic x(128).
+ 77 buflen pic x(4) comp-5.
+ procedure division.
+ move length of param-block to cblte-gpi-size.
+
+ * allocate handle
+ move 7 to cblte-gpi-flags.
+ move 0 to fn.
+ move length of buf to buflen.
+ call "CBL_GET_PROGRAM_INFO" using
+ by value fn
+ by reference param-block
+ buf
+ buflen
+ returning status-code.
+
+ if status-code <> 0
+ display "CBL_GET_PROGRAM_INFO failed with " status-code
+ goback
+ end-if.
+
+ display "buf is '" buf "'".
+
+ * retrieve program name from handle
+ move 6 to cblte-gpi-flags.
+ move 2 to fn.
+ move x"00" to buf.
+ call "CBL_GET_PROGRAM_INFO" using
+ by value fn
+ by reference param-block
+ buf
+ buflen
+ returning status-code.
+
+ if status-code <> 0
+ display "CBL_GET_PROGRAM_INFO failed with " status-code
+ goback
+ end-if.
+
+ display "buf from handle is '" buf "'".
+
+ * close handle
+ move 0 to cblte-gpi-flags.
+ move 3 to fn.
+ call "CBL_GET_PROGRAM_INFO" using
+ by value fn
+ by reference param-block
+ buf
+ buflen
+ returning status-code.
+
+ if status-code <> 0
+ display "CBL_GET_PROGRAM_INFO failed with " status-code
+ goback
+ end-if.
+ end program prog.
+
diff --git
a/gcc/testsuite/cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_f
unctions_0_and_2_.out
b/gcc/testsuite/cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_f
unctions_0_and_2_.out
new file mode 100644
index 00000000000..c86d093d767
--- /dev/null
+++
b/gcc/testsuite/cobol.dg/group2/CBL_GET_PROGRAM_INFO__get_program_name_-_f
unctions_0_and_2_.out
@@ -0,0 +1,3 @@
+buf is 'prog'
+buf from handle is 'prog'
+
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index f436e822889..4332d7ddee0 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -2140,7 +2140,6 @@ int128_to_field(cblc_field_t *var,
// Convert that string according to the PICTURE clause
__gg__string_to_numeric_edited(as_chars(location),
ach,
- target_rdigits,
is_negative,
var->picture);
size_t outlength;
@@ -2309,10 +2308,9 @@ __gg__int128_to_ascii_numeric_display(const
cblc_field_t *var,
// Convert that string according to the PICTURE clause
__gg__string_to_numeric_edited(as_chars(location),
- ach,
- var->rdigits,
- is_negative,
- var->picture);
+ ach,
+ is_negative,
+ var->picture);
}
return size_error;
}
diff --git a/libgcobol/valconv.cc b/libgcobol/valconv.cc
index 21e89f437dd..83bdaf09cba 100644
--- a/libgcobol/valconv.cc
+++ b/libgcobol/valconv.cc
@@ -138,12 +138,12 @@ __gg__alphabet_create( cbl_encoding_t encoding,
extern "C"
void
-__gg__string_to_numeric_edited( char * const dest,
+__gg__string_to_numeric_edited( char * const dest_,
const char *source, // In source
characters
- int /*rdigits*/,
int is_negative,
const char *picture)
{
+ unsigned char *dest = reinterpret_cast<unsigned char *>(dest_);
// This routine operates in ASCII space. Life is hard enough without
trying
// to do this in EBCDIC, too. So, 'source' and 'picture' are assumed
to be
// CP1252
@@ -159,8 +159,14 @@ __gg__string_to_numeric_edited( char * const dest,
// 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);
+
+ // We subtract the length of the extra characters that were appended to
the
+ // adjusted PICTURE string.
+
+ static const int MAX_POSSIBLE = 64 + 6; // See PICTURE_MAX in symbols.h
+
+ const int length_d = strlen(picture) - 6;
+ assert(length_d < MAX_POSSIBLE && length_d >= 0);
memcpy(dest, picture, length_d);
/* We have two kinds of floating insertion: currency and sign.
@@ -183,105 +189,72 @@ __gg__string_to_numeric_edited( char * const dest,
// 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_char = NULLCH;
+ unsigned char currency_char;
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, and mean
// separate things in IBM. In ISO COBOL, the comparison is
case-insensitive.
- // This is the character for a floating sign
- char sign_char;
-
- // In the following limits, all of the rightmosts are past-the-end
indexes
-
- int leftmost_currency = -1;
- int rightmost_currency = -1;
-
- int leftmost_sign = -1;
- int rightmost_sign = -1;
-
- int leftmost_asterisk = -1;
- int rightmost_asterisk = -1;
- int zeroed_asterisk = 0;
-
- int leftmost_z = -1;
- int rightmost_z = -1;
- int zeroed_z = 0;
-
+ unsigned char floating_char;
+ int leftmost_float = -1;
+ int rightmost_float = -1; // This is a one-past-the-end index
+ bool got_nines = false;
int leftmost_nonzero = -1;
-
int decimal_position = -1;
- // This is the first pass. Because the currency
+ unsigned const char *extra =
+ reinterpret_cast<unsigned const char
*>(picture+length_d);
+ currency_char = extra[0];
+ currency_text = __gg__currency_signs[currency_char].c_str();
+
+ floating_char = extra[1] != ascii_space ? extra[1] : NULLCH;
+ if( floating_char != ascii_space )
+ {
+ leftmost_float = (extra[2] & 0xF) * 10 + (extra[3] & 0xF);
+ rightmost_float = (extra[4] & 0xF) * 10 + (extra[5] & 0xF);
+ }
+ got_nines = !!(extra[2] & 0x40);
+
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() )
- {
- 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;
- }
+ unsigned char ch = dest[i];
+
if( ch == currency_char )
{
- // We have already handled the currency char.
- continue;
+ // Arriving here means we have hit a singleton currency character.
Since
+ // it is not part of a floating currency stream, the currency text
goes
+ // here.
+ memcpy(dest + i - (strlen(currency_text)-1),
+ currency_text,
+ strlen(currency_text));
}
+
switch(ch)
{
case ascii_minus:
case ascii_plus:
- {
+ // Arriving here means we have hit a singleton sign character
+ unsigned char sign_char;
if( is_negative )
{
sign_char = ascii_minus;
}
else
{
- if( ch == ascii_plus )
+ if( ch == ascii_minus )
{
- sign_char = ascii_plus;
+ sign_char = ascii_space;
}
else
{
- sign_char = ascii_space;
+ sign_char = ascii_plus;
}
}
- dest[i] = sign_char;
- if( leftmost_sign == -1 )
- {
- leftmost_sign = i;
- }
- else
- {
- // 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 )
- {
- leftmost_nonzero = i;
- }
- }
- rightmost_sign = i+1;
+ dest[i] = sign_char;
break;
- }
case ascii_comma:
case ascii_period:
@@ -289,36 +262,6 @@ __gg__string_to_numeric_edited( char * const dest,
{
decimal_position = i;
}
- break;
-
- 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;
-
- 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 )
- {
- dest[i] = ascii_space;
- }
- else if( length_d >= 1 )
- {
- if( dest[i-1] != ascii_D && dest[i-1] != ascii_d )
- {
- // This is an isolated B at the very end of the string
- dest[i] = ascii_space;
- }
- // Otherwise, that final B is part of a DB, and is left alone.
- }
break;
case ascii_9:
@@ -329,175 +272,130 @@ __gg__string_to_numeric_edited( char * const dest,
leftmost_nonzero = i;
}
break;
-
- case ascii_asterisk:
- // These are positions that hold digits
- if( leftmost_asterisk == -1 )
- {
- leftmost_asterisk = i;
- }
- rightmost_asterisk = i+1;
-
- dest[i] = source[index_s++];
- if( dest[i] == ascii_zero )
- {
- zeroed_asterisk += 1;
- }
- else
- {
- if( leftmost_nonzero == -1 )
- {
- leftmost_nonzero = i;
- }
- }
- break;
-
- case ascii_Z:
- // These are positions that hold digits
- if( leftmost_z == -1 )
- {
- leftmost_z = i;
- }
- rightmost_z = i+1;
-
- dest[i] = source[index_s++];
- if( dest[i] == ascii_zero )
- {
- zeroed_z += 1;
- }
- else
- {
- if( leftmost_nonzero == -1 )
- {
- leftmost_nonzero = i;
- }
- }
- break;
-
- default:
- abort();
}
}
// Do currency replacement
- if( leftmost_currency >= 0 )
+ if( floating_char == currency_char )
{
- if( leftmost_currency == rightmost_currency-1 )
+ // This is a floating currency symbol. We need to start at
+ // leftmost_float, and walk to the lesser of rightmost_float and
+ // leftmost_nonzero. We blank every character we encounter until we
+ // reach the first non-zero character.
+ int left = leftmost_float;
+ int right;
+ if( leftmost_nonzero >= 0 )
{
- // This is a solo currency symbol
- memcpy(dest + leftmost_currency - (strlen(currency_text)-1),
- currency_text,
- strlen(currency_text));
+ right = std::min(leftmost_nonzero, rightmost_float);
+ if( decimal_position >= 0 )
+ {
+ right = std::min(right, decimal_position);
+ }
}
else
{
- // 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);
+ right = rightmost_float;
+ }
+ // blank out that range
+ assert(right-left < MAX_POSSIBLE && right-left >= 0);
+ 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 )
- {
+ // 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 == decimal_position )
{
- right -= 1;
- memcpy(dest + right - (strlen(currency_text)-1),
- currency_text,
- strlen(currency_text));
+ 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));
}
}
// Do sign replacement
- if( leftmost_sign >= 0 )
+ if( floating_char == ascii_plus || floating_char == ascii_minus )
{
- if( leftmost_sign == rightmost_sign-1 )
+ // This is a floating sign symbol. We need to start at
+ // leftmost_float, and walk to the lesser of rightmost_float and
+ // leftmost_nonzero. We blank every character we encounter.
+ unsigned char sign_char;
+ if( is_negative )
{
- // This is a solo sign symbol
- dest[leftmost_sign] = sign_char;
+ sign_char = ascii_minus;
}
else
{
- // 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 )
+ if( floating_char == ascii_minus )
{
- right = std::min(leftmost_nonzero, rightmost_sign);
- if( decimal_position >= 0 )
- {
- right = std::min(right, decimal_position);
- }
+ sign_char = ascii_space;
}
else
{
- right = rightmost_sign;
+ sign_char = ascii_plus;
}
- // blank out that range
- memset(dest+left, ascii_space, right-left);
+ }
- // 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 )
+ int left = leftmost_float;
+ int right;
+ if( leftmost_nonzero >= 0 )
+ {
+ right = std::min(leftmost_nonzero, rightmost_float);
+ if( decimal_position >= 0 )
{
- if( (dest[right] >= ascii_zero && dest[right] <= ascii_nine)
- || right == decimal_position )
- {
- break;
- }
- dest[right] = ascii_space;
- right += 1;
+ right = std::min(right, decimal_position);
}
- if( right < length_d )
+ }
+ else
+ {
+ right = rightmost_float;
+ }
+ // blank out that range
+ assert(right-left < MAX_POSSIBLE && right-left >= 0);
+ memset(dest+left, ascii_space, right-left);
+
+ // 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 )
{
- right -= 1;
- dest[right] = sign_char;
+ break;
}
+ dest[right] = ascii_space;
+ right += 1;
+ }
+ if( right < length_d )
+ {
+ right -= 1;
+ dest[right] = sign_char;
}
}
// Do '*' zero suppression
- if( leftmost_asterisk >= 0 )
+ if( floating_char == ascii_asterisk )
{
- // This is a floating zero suppression.
+ // This is a floating zero suppression.
- int left = leftmost_asterisk;
+ int left = leftmost_float;
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(leftmost_nonzero, rightmost_float);
+ if( decimal_position >= 0 && decimal_position > leftmost_float )
{
right = std::min(right, decimal_position);
}
@@ -505,19 +403,19 @@ __gg__string_to_numeric_edited( char * const dest,
else
{
// The value being formatted is zero
- if( zeroed_asterisk == length_s )
+ if( leftmost_nonzero == -1 && !got_nines )
{
- // Every numeric position was a zero on asterisk, so the whole
thing
- // is starred.
+ // Every numeric position was a zero, and there were no explicit
nines
left = 0;
right = length_d;
}
else
{
- right = rightmost_asterisk;
+ right = rightmost_float;
}
}
- // blank out that range
+ // Fill that range with stars
+ assert(right-left < MAX_POSSIBLE && right-left >= 0);
memset(dest+left, ascii_asterisk, right-left);
// To handle situations like PIC ZZZ,999, where the suppression char
has to
@@ -526,7 +424,7 @@ __gg__string_to_numeric_edited( char * const dest,
while( right < length_d )
{
if( (dest[right] >= ascii_zero && dest[right] <= ascii_nine)
- || right == decimal_position )
+ || right == decimal_position )
{
break;
}
@@ -543,37 +441,38 @@ __gg__string_to_numeric_edited( char * const dest,
}
// Do 'Z' zero suppression
- if( leftmost_z >= 0 )
+ if( floating_char == ascii_Z )
{
- // This is a floating zero suppression.
+ // This is a floating zero suppression.
- int left = leftmost_z;
+ int left = leftmost_float;
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(leftmost_nonzero, rightmost_float);
+ if( decimal_position >= 0 && decimal_position > leftmost_float )
{
right = std::min(right, decimal_position);
}
}
else
{
- if( zeroed_z == length_s )
+ if( leftmost_nonzero == -1 && !got_nines )
{
- // Every numeric position was a zero on asterisk, so the whole
thing
+ // Every numeric position was a zero on 'Z', so the whole thing
// is blanked.
left = 0;
right = length_d;
}
else
{
- right = rightmost_z;
+ right = rightmost_float;
}
}
// blank out that range
+ assert(right-left < MAX_POSSIBLE && right-left >= 0);
memset(dest+left, ascii_space, right-left);
// To handle situations like PIC ZZZ,999, where the suppression char
has to
@@ -582,7 +481,7 @@ __gg__string_to_numeric_edited( char * const dest,
while( right < length_d )
{
if( (dest[right] >= ascii_zero && dest[right] <= ascii_nine)
- || right == decimal_position )
+ || right == decimal_position )
{
break;
}
@@ -591,10 +490,11 @@ __gg__string_to_numeric_edited( char * const dest,
}
}
- // Any final DB/CR needs to be addressed:
- if( !is_negative
- && length_d >= 2
- && ( dest[length_d-2] == ascii_D
+ // Any final DB/CR needs to be addressed. If the number is positive,
or
+ // all the digits were zeroes, then blank any CR/DB at the end:
+ if( (!is_negative || leftmost_nonzero < 0)
+ && 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 ) )
diff --git a/libgcobol/valconv.h b/libgcobol/valconv.h
index 62ee342c2b0..cbd2a2194f5 100644
--- a/libgcobol/valconv.h
+++ b/libgcobol/valconv.h
@@ -55,7 +55,6 @@ extern "C"
int high_char );
void __gg__string_to_numeric_edited(char * const dest,
const char *source, // ASCII
- int rdigits,
int is_negative,
const char *picture);
void __gg__string_to_alpha_edited(char *dest,
--
2.34.1
