On-the-fly BCD normalization

cobc/ChangeLog

@@ -1,4 +1,9 @@
 
+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-02  Simon Sobisch <[email protected]>
 
 	* pplex.l (output_line_directive): extracted from other places and

cobc/codegen.c

@@ -11391,6 +11391,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 ();

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",

config/ChangeLog

@@ -1,4 +1,8 @@
 
+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

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'

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'

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'

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'

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'

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'

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:			yes	# TODO: verify
 
+# Normalize BCD on-the-fly
+normalize-bcd:			yes
+
 # Dialect features
 # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error',
 #        'unconformable'

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'

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'

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'

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'

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'

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'

libcob/ChangeLog

@@ -1,4 +1,13 @@
 
+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-10-22  Chuck Haatvedt <[email protected]>
 
 	* screenio.c (cob_screen_get_all): fixed Bug #999

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

libcob/common.c

@@ -3843,6 +3843,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)

libcob/common.h

@@ -1335,6 +1335,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;
 
 

libcob/move.c

@@ -296,6 +296,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;
@@ -312,21 +313,34 @@ 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) {
+				if (COB_D2I (*p) >= 0 && COB_D2I (*p) <= 9) {
+					++count;
+				}
 			}
 		}
 	}
@@ -336,34 +350,69 @@ 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++;
+			}
+		} else {
+			while (count-- > size) {
+				while (COB_D2I (*s1) < 0 || COB_D2I (*s1) > 9) {
+					s1++;
+				}
 				s1++;
 			}
-			s1++;
 		}
 	}
 
 	/* 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) {
+			if (COB_D2I (*s1) >= 0 && COB_D2I (*s1) <= 9) {
+#ifndef	COB_EBCDIC_MACHINE
+				*s2++ = (COB_D2I (*s1) | 0x30);
+#else
+				*s2++ = (COB_D2I (*s1) | 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

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 */

tests/testsuite.src/configuration.at

@@ -460,6 +460,7 @@ test.conf: missing definitions:
 	no definition of 'device-mnemonics'
 	no definition of 'xml-parse-xmlss'
 	no definition of 'areacheck'
+	no definition of 'normalize-bcd'
 	no definition of 'comment-paragraphs'
 	no definition of 'control-division'
 	no definition of 'partial-replace-when-literal-src'