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

cobc/ChangeLog

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

cobc/codegen.c

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

@@ -17,6 +17,10 @@
 
 	* config/runtime.cfg: add COB_LOAD_GLOBAL
 
+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

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:			no
 
+# 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

@@ -262,6 +262,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, store_common_region),
+	  numeric.c (cob_decimal_set_display): perform BCD
+	  normalization when flag_normalize_bcd is set
+
 2024-11-24  Simon Sobisch <simonsobisch@gnu.org>
 
 	* numeric.c (mpz_get_ull, mpz_get_sll, cob_decimal_get_binary):

libcob/coblocal.h

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

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

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

@@ -189,14 +189,16 @@ store_common_region (cob_field *f, const unsigned char *data,
 
 			while (dst < end) {
 				const char src_data = *src++;
-#if 0		/* seems to be the best result, ..." */
-				/* we don't want to set bad data, so
-				   only take the half byte */
-				*dst = COB_I2D (COB_D2I (src_data));
-#else		/* but does not match the "expected" MF result, which is: */
-				if (src_data == ' ' || src_data == 0) /* already set: *dst = '0'; */ ;
-				else *dst = COB_I2D (src_data - '0');
-#endif
+				if (COB_MODULE_PTR->flag_normalize_bcd) {
+					/* seems to be the best result, ..." */
+					/* we don't want to set bad data, so
+					   only take the half byte */
+					*dst = COB_I2D (COB_D2I (src_data));
+				} else {
+					/* but does not match the "expected" MF result, which is: */
+					if (src_data == ' ' || src_data == 0) /* already set: *dst = '0'; */ ;
+					else *dst = COB_I2D (src_data - '0');
+				}
 				++dst;
 			}
 		}
@@ -309,6 +311,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 +328,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 +366,66 @@ 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) {
+				*s2++ = COB_I2D (d);
+			} 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