On-the-fly BCD normalization

ddeclerck · ddeclerck · commit 55b73dc17630 · 2025-01-19T23:52:15.000+01:00
diff --git a/cobc/ChangeLog b/cobc/ChangeLog
@@ -3,6 +3,11 @@
 
 	* cobc.c (process_command_line): fix leak for --copy and -include parsing
 
+2024-12-05  David Declerck <david.declerck@ocamlpro.com>
+
+	* config.def: new normalize-bcd dialect option
+	* codegen.c (output_module_init_function): initialize flag_normalize_bcd
+
 2024-10-30  Chuck Haatvedt <chuck.haatvedt+cobol@gmail.com>
 
 	* typeck.c: define [WITH_EXTENDED_SCREENIO] for any curses headers
diff --git a/cobc/codegen.c b/cobc/codegen.c
@@ -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 ();
diff --git a/cobc/config.def b/cobc/config.def
@@ -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",
diff --git a/config/ChangeLog b/config/ChangeLog
@@ -3,6 +3,10 @@
 
 	* gcos-strict.conf: set init-justify to no after testing on GCOS
 
+2024-12-05  David Declerck <david.declerck@ocamlpro.com>
+
+	* general: add the normalize-bcd dialect option (active only for GCOS)
+
 2024-08-17 Ammar Almoris <ammaralmorsi@gmail.com>
 
 	FR #474: add runtime configuration to hide cursor for extended screenio
diff --git a/config/acu-strict.conf b/config/acu-strict.conf
@@ -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'
diff --git a/config/bs2000-strict.conf b/config/bs2000-strict.conf
@@ -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'
diff --git a/config/cobol2002.conf b/config/cobol2002.conf
@@ -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'
diff --git a/config/cobol2014.conf b/config/cobol2014.conf
@@ -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'
diff --git a/config/cobol85.conf b/config/cobol85.conf
@@ -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'
diff --git a/config/default.conf b/config/default.conf
@@ -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'
diff --git a/config/gcos-strict.conf b/config/gcos-strict.conf
@@ -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'
diff --git a/config/ibm-strict.conf b/config/ibm-strict.conf
@@ -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'
diff --git a/config/mf-strict.conf b/config/mf-strict.conf
@@ -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'
diff --git a/config/mvs-strict.conf b/config/mvs-strict.conf
@@ -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'
diff --git a/config/realia-strict.conf b/config/realia-strict.conf
@@ -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'
diff --git a/config/rm-strict.conf b/config/rm-strict.conf
@@ -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'
diff --git a/config/xopen.conf b/config/xopen.conf
@@ -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'
diff --git a/libcob/ChangeLog b/libcob/ChangeLog
@@ -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 <david.declerck@ocamlpro.com>
+
+	* 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 <david.declerck@ocamlpro.com>
 
 	* move.c (optimized_move_display_to_edited): minor refactoring
diff --git a/libcob/coblocal.h b/libcob/coblocal.h
@@ -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
diff --git a/libcob/common.c b/libcob/common.c
@@ -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);
+	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)
diff --git a/libcob/common.h b/libcob/common.h
@@ -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;
 
 
diff --git a/libcob/move.c b/libcob/move.c
@@ -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;
 	int		sign;
 	int		count;
 	int		size;
@@ -325,21 +326,35 @@ cob_move_alphanum_to_display (cob_field *f1, cob_field *f2)
 
 	/* 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) {
+					++count;
+				}
 			}
 		}
 	}
@@ -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
+			} else if (*s1 == dec_pt) {
+				if (count++ > 0) {
+					goto error;
+				}
+			} else if (!(isspace (*s1) || *s1 == num_sep)) {
 				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
diff --git a/libcob/numeric.c b/libcob/numeric.c
@@ -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)) {
@@ -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 */
diff --git a/tests/testsuite.src/configuration.at b/tests/testsuite.src/configuration.at
diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at

Original file line number	Diff line number	Diff line change
`@@ -11389,6 +11389,7 @@ output_module_init_function (struct cb_program *prog)`
`11389`	`11389`	`} else {`
`11390`	`11390`	`output_line ("module->module_sources = NULL;");`
`11391`	`11391`	`}`
	`11392`	`+ output_line ("module->flag_normalize_bcd = %d;", cb_normalize_bcd);`
`11392`	`11393`
`11393`	`11394`	`output_block_close ();`
`11394`	`11395`	`output_newline ();`