From 8cfef3b24d417a5c675219c24c721f660eae85a3 Mon Sep 17 00:00:00 2001 From: Saurabh Kumar Date: Wed, 25 Mar 2026 12:45:51 +0530 Subject: [PATCH 1/3] feat: implement intrinsic function BOOLEAN-OF-INTEGER Signed-off-by: Saurabh Kumar --- cobc/reserved.c | 2 +- cobc/tree.c | 2 +- libcob/intrinsic.c | 97 +++++++++++++++++++++++++++++++++++++++++++--- 3 files changed, 94 insertions(+), 7 deletions(-) diff --git a/cobc/reserved.c b/cobc/reserved.c index 034201770..5951227ad 100644 --- a/cobc/reserved.c +++ b/cobc/reserved.c @@ -3308,7 +3308,7 @@ static struct cb_intrinsic_table function_list[] = { }, { "BOOLEAN-OF-INTEGER", "cob_intr_boolean_of_integer", CB_INTR_BOOLEAN_OF_INTEGER, FUNCTION_NAME, - CB_FEATURE_NOT_IMPLEMENTED, 2, 2, + CB_FEATURE_ACTIVE, 2, 2, CB_CATEGORY_NUMERIC, 0 }, { "BYTE-LENGTH", "cob_intr_byte_length", diff --git a/cobc/tree.c b/cobc/tree.c index f5735f5cc..b3729cfba 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -7236,6 +7236,7 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, /* Fixme: should validate following are taking integers */ case CB_INTR_TEST_DATE_YYYYMMDD: case CB_INTR_TEST_DAY_YYYYDDD: + case CB_INTR_BOOLEAN_OF_INTEGER: x = CB_VALUE (args); if (cb_tree_category (x) != CB_CATEGORY_NUMERIC) { cb_error_x (func, _("FUNCTION '%s' has invalid argument"), name); @@ -7244,7 +7245,6 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, return make_intrinsic (func, cbp, args, NULL, refmod, 0); case CB_INTR_ANNUITY: - case CB_INTR_BOOLEAN_OF_INTEGER: case CB_INTR_CHAR: case CB_INTR_CHAR_NATIONAL: case CB_INTR_COMBINED_DATETIME: diff --git a/libcob/intrinsic.c b/libcob/intrinsic.c index 0aec31248..370618c87 100644 --- a/libcob/intrinsic.c +++ b/libcob/intrinsic.c @@ -77,6 +77,9 @@ static cob_global *cobglobptr; static const cob_field_attr const_alpha_attr = {COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL}; +static const cob_field_attr const_boolean_attr = + {COB_TYPE_BOOLEAN, 0, 0, 0, NULL}; + /* Working fields */ static cob_field *move_field; @@ -7101,15 +7104,99 @@ cob_intr_content_of (const int offset, const int length, const int params, ...) return curr_field; } -/* RXWRXW - To be implemented */ +int is_little_endian(void) { + unsigned int x = 1; + return *((unsigned char *)&x) == 1; +} +/* + Converts a positive integer `val` to it's binary representation truncated or + padded to match `bitwidth` bits. +*/ cob_field * -cob_intr_boolean_of_integer (cob_field *f1, cob_field *f2) +cob_intr_boolean_of_integer(cob_field *val, cob_field *bitwidth) { - COB_UNUSED (f1); - COB_UNUSED (f2); + cob_s64_t int_val; + size_t int_bitwidth; + cob_field field; + int i, bit, binary_string_start_pos; + + /* `val` can be a large value */ + int_val = cob_get_llint(val); + int_bitwidth = cob_get_int(bitwidth); + + /* + `val` should be a positive integer. + `bitwidth` should be a positive non-zero integer. + */ + if (int_val < 0 || int_bitwidth < 1) { + cob_set_exception(COB_EC_ARGUMENT_FUNCTION); + cob_alloc_set_field_uint(0); + return curr_field; + } - error_not_implemented (); + /* Based on https://stackoverflow.com/a/61938224 */ + /* Get raw memory reprensentation in bytes. */ + unsigned char *bytes = (unsigned char *)&int_val; + + COB_FIELD_INIT(int_bitwidth, NULL, &const_boolean_attr); + make_field_entry (&field); + + int little_endian = is_little_endian(); + + /* Get effective occupied size of `int_val` in memory. */ + size_t effective_val_size = 0; + /* Go to most significant byte */ + unsigned char *byte = little_endian + ? &bytes[sizeof(int_val) - 1] + : &bytes[0]; + + /* Count empty bytes */ + int num_empty_bytes = 0; + while (*byte == 0) { + num_empty_bytes++; + if (little_endian) { + byte--; + } else { + byte++; + } + } + + effective_val_size = (sizeof(int_val) - num_empty_bytes) * 8; + + /* This is the position where our output bit value starts */ + binary_string_start_pos = int_bitwidth > effective_val_size + ? int_bitwidth - effective_val_size + : 0; + + memset(curr_field->data, '0', int_bitwidth); + + bit = 0; + if (little_endian) { + /* Go back to the least significant byte */ + bytes = &bytes[0]; + for (i = int_bitwidth - 1; i >= binary_string_start_pos; i--) { + curr_field->data[i] = *bytes & (1 << bit++) ? '1' : '0'; + if (bit % 8 == 0) { + /* Move to next byte */ + bit = 0; + bytes++; + } + } + } else { + /* Go back to the least significant byte */ + bytes = &bytes[(effective_val_size / 8) - 1]; + for (i = binary_string_start_pos; i < int_bitwidth; i++) { + curr_field->data[i] = *bytes & (1 << bit++) ? '1' : '0'; + if (bit % 8 == 0) { + /* Move to next byte */ + bit = 0; + bytes--; + } + } + } + + return curr_field; } /* implementation of FUNCTION CHAR-NATIONAL - character from ordinal From c77dbb4b130a58e522309141fc04e91516c4841e Mon Sep 17 00:00:00 2001 From: Saurabh Kumar Date: Wed, 25 Mar 2026 12:46:16 +0530 Subject: [PATCH 2/3] tests: add test Signed-off-by: Saurabh Kumar --- tests/testsuite.src/run_functions.at | 55 ++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) diff --git a/tests/testsuite.src/run_functions.at b/tests/testsuite.src/run_functions.at index 452f65b79..3aaf50625 100644 --- a/tests/testsuite.src/run_functions.at +++ b/tests/testsuite.src/run_functions.at @@ -4657,3 +4657,58 @@ Return value '5'], []) AT_CLEANUP +AT_SETUP([FUNCTION BOOLEAN-OF-INTEGER]) +AT_KEYWORDS([functions literal ibm]) + +AT_DATA([prog.cob], [ + >> SOURCE FREE + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAL PIC 9(5) VALUE 25. + 01 BOOL-VAL PIC 1(20). + PROCEDURE DIVISION. + *> TODO: BOOLEAN-OF-INTEGER returns a value of USAGE BIT. + *> Modify test when USAGE BIT is supported. + + *> Bit length matches exactly with that of the binary representation + IF FUNCTION BOOLEAN-OF-INTEGER(VAL, 8) NOT = "00011001" + DISPLAY "UNEXPECTED BIT-VALUE, expected 00011001, got: " + FUNCTION BOOLEAN-OF-INTEGER(VAL, 8). + + *> Bit length is less than the length of binary representation + IF FUNCTION BOOLEAN-OF-INTEGER(VAL, 3) NOT = "001" + DISPLAY "UNEXPECTED BIT-VALUE, expected 001, got: " + FUNCTION BOOLEAN-OF-INTEGER(VAL, 3). + + *> Bit length is more than the length of binary representation + *> Also, the passed integer is multi-byte + MOVE 1008 TO VAL. + IF FUNCTION BOOLEAN-OF-INTEGER(VAL, 20) NOT = "00000000001111110000" + DISPLAY "UNEXPECTED BIT-VALUE, expected 00000000001111110000, got: " + FUNCTION BOOLEAN-OF-INTEGER(VAL, 20). + + *> Special case, check 0 + MOVE 0 TO VAL. + IF FUNCTION BOOLEAN-OF-INTEGER(VAL, 12) NOT = "000000000000" + DISPLAY "UNEXPECTED BIT-VALUE, expected 000000000000, got: " + FUNCTION BOOLEAN-OF-INTEGER(VAL, 12). + + *> Check an integer which has a central byte full of zeroes + *> Here, we are essentially checking if our implementation can correctly + *> get number of used bytes in an integer. + MOVE 65664 TO VAL. + MOVE FUNCTION BOOLEAN-OF-INTEGER(VAL, 20) TO BOOL-VAL. + IF BOOL-VAL NOT = "00010000000010000000" + DISPLAY "UNEXPECTED BIT-VALUE, expected 00010000000010000000, got: " + BOOL-VAL. + + STOP RUN. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + From bf23a4cc3fb9ddac345ca9e86073501b4afbf5c6 Mon Sep 17 00:00:00 2001 From: Saurabh Kumar Date: Wed, 25 Mar 2026 12:46:32 +0530 Subject: [PATCH 3/3] chore: update ChangeLog Signed-off-by: Saurabh Kumar --- cobc/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index cce36250c..b3b14838f 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,9 @@ +2026-03-25 Saurabh Kumar + + * intrinsic.c, reserved.c, tree.c (cb_build_intrinsic): + implement intrinsic function BOOLEAN-OF-INTEGER + 2025-12-29 Roger Bowler * tree.c (finalize_file): if file is EXTFH enabled then don't warn for