Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Dialect option: normalize BCD "on-the-fly" when moving from ALPHANUMERIC to NUMERIC #200

Open
wants to merge 1 commit into
base: gcos4gnucobol-3.x
Choose a base branch
from
Open

Dialect option: normalize BCD "on-the-fly" when moving from ALPHANUMERIC to NUMERIC #200

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 5 additions & 0 deletions cobc/ChangeLog
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,11 @@

* cobc.c (process_command_line): fix leak for --copy and -include parsing

2024-12-05 David Declerck <[email protected]>

* config.def: new normalize-bcd dialect option
* codegen.c (output_module_init_function): initialize flag_normalize_bcd

2024-10-30 Chuck Haatvedt <[email protected]>

* typeck.c: define [WITH_EXTENDED_SCREENIO] for any curses headers
Expand Down
1 change: 1 addition & 0 deletions cobc/codegen.c
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -11389,6 +11389,7 @@ output_module_init_function (struct cb_program *prog)
} else {
output_line ("module->module_sources = NULL;");
}
output_line ("module->flag_normalize_bcd = %d;", cb_normalize_bcd);

output_block_close ();
output_newline ();
Expand Down
3 changes: 3 additions & 0 deletions cobc/config.def
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -203,6 +203,9 @@ CB_CONFIG_BOOLEAN (cb_areacheck, "areacheck",
" * statements must not start in Area A; and\n"
" * separator periods must not be within Area A"))

CB_CONFIG_BOOLEAN (cb_normalize_bcd, "normalize-bcd",
_("normalize BCD on-the-fly"))

/* Support flags */

CB_CONFIG_SUPPORT (cb_comment_paragraphs, "comment-paragraphs",
Expand Down
4 changes: 4 additions & 0 deletions config/ChangeLog
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,10 @@

* gcos-strict.conf: set init-justify to no after testing on GCOS

2024-12-05 David Declerck <[email protected]>

* general: add the normalize-bcd dialect option (active only for GCOS)

2024-08-17 Ammar Almoris <[email protected]>

FR #474: add runtime configuration to hide cursor for extended screenio
Expand Down
3 changes: 3 additions & 0 deletions config/acu-strict.conf
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -202,6 +202,9 @@ subscript-check: max
# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage
init-justify: no

# Normalize BCD on-the-fly
normalize-bcd: no

# Dialect features
# Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error',
# 'unconformable'
Expand Down
3 changes: 3 additions & 0 deletions config/bs2000-strict.conf
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -200,6 +200,9 @@ subscript-check: max # not verified, may need "record"
# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage
init-justify: no

# Normalize BCD on-the-fly
normalize-bcd: no

# Dialect features
# Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error',
# 'unconformable'
Expand Down
3 changes: 3 additions & 0 deletions config/cobol2002.conf
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -199,6 +199,9 @@ subscript-check: full
# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage
init-justify: no

# Normalize BCD on-the-fly
normalize-bcd: no

# Dialect features
# Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error',
# 'unconformable'
Expand Down
3 changes: 3 additions & 0 deletions config/cobol2014.conf
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -199,6 +199,9 @@ subscript-check: full
# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage
init-justify: no

# Normalize BCD on-the-fly
normalize-bcd: no

# Dialect features
# Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error',
# 'unconformable'
Expand Down
3 changes: 3 additions & 0 deletions config/cobol85.conf
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -199,6 +199,9 @@ subscript-check: full
# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage
init-justify: no

# Normalize BCD on-the-fly
normalize-bcd: no

# Dialect features
# Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error',
# 'unconformable'
Expand Down
3 changes: 3 additions & 0 deletions config/default.conf
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -219,6 +219,9 @@ subscript-check: full
# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage
init-justify: no

# Normalize BCD on-the-fly
normalize-bcd: no

# Dialect features
# Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error',
# 'unconformable'
Expand Down
3 changes: 3 additions & 0 deletions config/gcos-strict.conf
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -198,6 +198,9 @@ subscript-check: max # not verified, may need "record"
# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage
init-justify: no

# Normalize BCD on-the-fly
normalize-bcd: yes

# Dialect features
# Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error',
# 'unconformable'
Expand Down
3 changes: 3 additions & 0 deletions config/ibm-strict.conf
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -198,6 +198,9 @@ subscript-check: max # TODO: "record"
# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage
init-justify: yes

# Normalize BCD on-the-fly
normalize-bcd: no

# Dialect features
# Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error',
# 'unconformable'
Expand Down
3 changes: 3 additions & 0 deletions config/mf-strict.conf
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -201,6 +201,9 @@ subscript-check: max
# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage
init-justify: no

# Normalize BCD on-the-fly
normalize-bcd: no

# Dialect features
# Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error',
# 'unconformable'
Expand Down
3 changes: 3 additions & 0 deletions config/mvs-strict.conf
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -198,6 +198,9 @@ subscript-check: max # TODO: "record"
# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage
init-justify: yes

# Normalize BCD on-the-fly
normalize-bcd: no

# Dialect features
# Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error',
# 'unconformable'
Expand Down
3 changes: 3 additions & 0 deletions config/realia-strict.conf
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -202,6 +202,9 @@ subscript-check: full # not verified yet
# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage
init-justify: no

# Normalize BCD on-the-fly
normalize-bcd: no

# Dialect features
# Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error',
# 'unconformable'
Expand Down
3 changes: 3 additions & 0 deletions config/rm-strict.conf
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -205,6 +205,9 @@ subscript-check: max
# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage
init-justify: no

# Normalize BCD on-the-fly
normalize-bcd: no

# Dialect features
# Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error',
# 'unconformable'
Expand Down
3 changes: 3 additions & 0 deletions config/xopen.conf
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -212,6 +212,9 @@ subscript-check: full
# Functionality of JUSTIFY for INITIALIZE verb and initialization of storage
init-justify: no

# Normalize BCD on-the-fly
normalize-bcd: no

# Dialect features
# Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error',
# 'unconformable'
Expand Down
9 changes: 9 additions & 0 deletions libcob/ChangeLog
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -43,6 +43,15 @@
* screenio.c [WITH_PANELS]: replace use of ncurses extension ceiling_panel()
with X/Open Curses function panel_below()

2024-12-05 David Declerck <[email protected]>

* common.h: new flag_normalize_bcd field in cob_module
* common.c, coblocal.h (cob_get_sign_from_alnum): new function
to retrieve the "sign" of an ALPHANUMERIC field
* move.c (cob_move_alphanum_to_display),
numeric.c (cob_decimal_set_display): perform BCD
normalization when flag_normalize_bcd is set

2024-11-22 David Declerck <[email protected]>

* move.c (optimized_move_display_to_edited): minor refactoring
Expand Down
1 change: 1 addition & 0 deletions libcob/coblocal.h
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -483,6 +483,7 @@ COB_HIDDEN FILE *cob_create_tmpfile (const char *);
COB_HIDDEN int cob_check_numval_f (const cob_field *);

COB_HIDDEN int cob_real_get_sign (cob_field *, const int);
COB_HIDDEN int cob_get_sign_from_alnum (cob_field *);
COB_HIDDEN void cob_real_put_sign (cob_field *, const int);

#ifndef COB_WITHOUT_DECIMAL
Expand Down
19 changes: 19 additions & 0 deletions libcob/common.c
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -3881,6 +3881,25 @@ cob_real_get_sign (cob_field *f, const int adjust_ebcdic)
return 0;
}

/* get the "sign" from an alphanumeric field, as if the field
was numeric display with non-separate trailing sign */
int
cob_get_sign_from_alnum (cob_field *f)
{
int sign;
cob_field_attr attr;
cob_field field;
COB_FIELD_INIT (COB_FIELD_SIZE (f), COB_FIELD_DATA (f), &attr);
COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, COB_FIELD_SIZE (f), 0, COB_FLAG_HAVE_SIGN, NULL);
sign = cob_real_get_sign (&field, 0);
Comment on lines +3889 to +3894
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Wouldn't it be more reasonable to duplicate the code of the called functions here? This way we don't need an intermediate field definition, just getting const char *p last_data = f->data + f->size - 1; and check p as in the function above?

if (sign < 0) {
return -1;
} else if (sign > 0) {
return 1;
}
return 0;
}

/* store sign to DISPLAY/PACKED fields */
void
cob_real_put_sign (cob_field *f, const int sign)
Expand Down
2 changes: 2 additions & 0 deletions libcob/common.h
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1337,6 +1337,8 @@ typedef struct __cob_module {
const char *paragraph_name; /* name of current active pagagraph */
enum cob_statement statement; /* statement currently executed */

unsigned char flag_normalize_bcd; /* Should BCD be normalized on-the-fly ? */

} cob_module;


Expand Down
83 changes: 67 additions & 16 deletions libcob/move.c
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -309,6 +309,7 @@ cob_move_alphanum_to_display (cob_field *f1, cob_field *f2)
const unsigned char *e2 = s2 + COB_FIELD_SIZE (f2);
const unsigned char dec_pt = COB_MODULE_PTR->decimal_point;
const unsigned char num_sep = COB_MODULE_PTR->numeric_separator;
unsigned char last;
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

What do we need that for? The called function doesn't change the data, does it?
(numeric.c (cob_decimal_set_display) may change that, so that's a different thing)

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Since this function (indirectly) calls cob_real_get_sign, which alters the byte holding the sign (always trailing when normalizing), we have to save/restore it (or maybe we could use cob_put_sign).

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

If we drop the "normalize bcd function" and get the sign "directly", then we don't need to "unpunch" anything and therefore don't need to store/reset that position, do we?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yeah, probably. I'll dive further into this.

int sign;
int count;
int size;
Expand All @@ -325,21 +326,35 @@ cob_move_alphanum_to_display (cob_field *f1, cob_field *f2)

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

directly above this code there is a skipping of leading spaces; if we always check the half-byte only, then this should be checked via COB_D2I instead (otherwise it should be done that way depending on the dialect configuration) ... but somehow care would have to be taken to explicit match the leading +/- as character (I don't mind if this only happens after real space or also after zero; in which case we can handle both sign and leading space/zero in one loop; I also wouldn't mind iterating over everything until we don't find +/-/non-zero COB_D2I

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The thing is, something like ' -123' (where the blank before 123 is a tab - code 0x05 in EBCDIC, and considering minus has code 0x60) normalizes as 50123 on GCOS (checked). The same with a space instead of the tab normalizes as 00123. Depending on whether we use isspace or COB_D2I, and whether we consider the possibility of a leading sign, we'll get different results. I'm not sure what would be the best thing to do. Maybe we could have an option (not a dialect one) to specify which kind of sign to expect (leading separate, trailing embedded, none...) ?

/* Check for sign */
sign = 0;
if (s1 != e1) {
if (*s1 == '+' || *s1 == '-') {
sign = (*s1++ == '+') ? 1 : -1;
if (!COB_MODULE_PTR->flag_normalize_bcd) {
if (s1 != e1) {
if (*s1 == '+' || *s1 == '-') {
sign = (*s1++ == '+') ? 1 : -1;
}
}
} else {
last = f1->data[f1->size - 1];
sign = cob_get_sign_from_alnum (f1);
}

/* Count the number of digits before decimal point */
count = 0;
{
register unsigned char *p;
for (p = s1; p < e1 && *p != dec_pt; ++p) {
if (!COB_MODULE_PTR->flag_normalize_bcd) {
for (p = s1; p < e1 && *p != dec_pt; ++p) {
/* note: as isdigit is locale-aware (slower and not what we want),
we use a range check instead */
if (*p >= '0' && *p <= '9') {
++count;
if (*p >= '0' && *p <= '9') {
++count;
}
}
} else {
for (p = s1; p < e1 && *p != dec_pt; ++p) {
const char d = COB_D2I (*p);
if (d >= 0 && d <= 9) {
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This code also counts (not skip) spaces that way - does this match the expected result?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Actually what happens on GCOS is very different. I had not taken into account what happens when there is a decimal point... While the current GnuCOBOL only moves digits that are before the decimal point, GCOS tries to move and normalize all digits. If it encounters a decimal point, it raises an exception because the decimal point - no matter if it is a comma (0x6B) or a dot (0x4B) - does not normalize to a valid digit...

In fact, GnuCOBOL tries to be smart - skips leading spaces, interprets the sign and the decimal point, while GCOS (and others) more or less boldly convert whatever is there. But how much do we want to keep the original GnuCOBOL behavior ? If we do want to keep it (to not break existing programs), we might as well just have two different normalization functions.

++count;
}
}
}
}
Expand All @@ -349,34 +364,70 @@ cob_move_alphanum_to_display (cob_field *f1, cob_field *f2)
if (count < size) {
s2 += size - count;
} else {
while (count-- > size) {
while (*s1 < '0' || *s1 > '9') {
if (!COB_MODULE_PTR->flag_normalize_bcd) {
while (count-- > size) {
while (*s1 < '0' || *s1 > '9') {
s1++;
}
s1++;
}
s1++;
} else {
while (count-- > size) {
char d;
do {
d = COB_D2I (*s1++);
} while (d < 0 || d > 9);
}
}
}

/* Move */
count = 0;
for (; s1 < e1 && s2 < e2; ++s1) {
if (*s1 >= '0' && *s1 <= '9') {
*s2++ = *s1;
} else if (*s1 == dec_pt) {
if (count++ > 0) {
if (!COB_MODULE_PTR->flag_normalize_bcd) {
for (; s1 < e1 && s2 < e2; ++s1) {
if (*s1 >= '0' && *s1 <= '9') {
*s2++ = *s1;
} else if (*s1 == dec_pt) {
if (count++ > 0) {
goto error;
}
} else if (!(isspace (*s1) || *s1 == num_sep)) {
goto error;
}
}
} else {
for (; s1 < e1 && s2 < e2; ++s1) {
const char d = COB_D2I (*s1);
if (d >= 0 && d <= 9) {
#ifndef COB_EBCDIC_MACHINE
*s2++ = (d | 0x30);
#else
*s2++ = (d | 0xF0);
#endif
Comment on lines +402 to +406
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Why not using COB_I2D here?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Indeed, COB_I2D should be used.

} else if (*s1 == dec_pt) {
if (count++ > 0) {
goto error;
}
} else if (!(isspace (*s1) || *s1 == num_sep)) {
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

we will never get into the isspace case here, as that would be the integer 0 - so the code should be adjusted to either check for space first or drop the check completely

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

True indeed.

goto error;
}
} else if (!(isspace (*s1) || *s1 == num_sep)) {
goto error;
}
}

COB_PUT_SIGN (f2, sign);
if (COB_MODULE_PTR->flag_normalize_bcd
&& !COB_FIELD_CONSTANT (f1)) {
f1->data[f1->size - 1] = last;
}
return;

error:
memset (f2->data, '0', f2->size);
COB_PUT_SIGN (f2, 0);
if (COB_MODULE_PTR->flag_normalize_bcd
&& !COB_FIELD_CONSTANT (f1)) {
f1->data[f1->size - 1] = last;
}
}

static void
Expand Down
18 changes: 16 additions & 2 deletions libcob/numeric.c
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1446,7 +1446,16 @@ cob_decimal_set_display (cob_decimal *d, cob_field *f)

register unsigned char *data = COB_FIELD_DATA (f);
register unsigned int size = (unsigned int) COB_FIELD_SIZE (f);
const int sign = COB_GET_SIGN_ADJUST (f);
unsigned char last;
int sign;

if (COB_MODULE_PTR->flag_normalize_bcd
&& COB_FIELD_IS_ANY_ALNUM (f)) {
last = f->data[f->size - 1];
sign = cob_get_sign_from_alnum (f);
} else {
sign = COB_GET_SIGN_ADJUST (f);
}

/* TODO: document special cases here */
if (unlikely (*data == 255)) {
Expand Down Expand Up @@ -1540,7 +1549,12 @@ cob_decimal_set_display (cob_decimal *d, cob_field *f)
}
d->scale = COB_FIELD_SCALE (f);

COB_PUT_SIGN_ADJUSTED (f, sign);
if (COB_MODULE_PTR->flag_normalize_bcd
&& COB_FIELD_IS_ANY_ALNUM (f)) {
f->data[f->size - 1] = last;
} else {
COB_PUT_SIGN_ADJUSTED (f, sign);
}
}

/* store value from decimal into field of type numeric DISPLAY */
Expand Down
Loading
Loading