From 934f032fcde44f5a5b2dafffbb2fb90936d795d2 Mon Sep 17 00:00:00 2001
From: Bob Dubner <rdubner@symas.com>
Date: Thu, 16 Jan 2025 10:27:10 -0500
Subject: [PATCH] 88 named-conditional comparisons for floating-point
---
gcc/cobol/ChangeLog | 3 +
.../UAT/testsuite.src/run_fundamental.at | 86 ++++++++-
libgcobol/libgcobol.cc | 171 ++++++++++++------
3 files changed, 201 insertions(+), 59 deletions(-)
diff --git a/gcc/cobol/ChangeLog b/gcc/cobol/ChangeLog
index f2c8b008a6e5..3dfff187eefd 100644
--- a/gcc/cobol/ChangeLog
+++ b/gcc/cobol/ChangeLog
@@ -91,4 +91,7 @@
* Modify line directives to skip over paragraph/section labels:
* Unwrapped asprintf calls in assert(), because it was a stupid error.
+2025-01-16 Robert Dubner <rdubner@symas.com>
+ * Code 88 named-conditional comparisons for floating-point
+
diff --git a/gcc/cobol/UAT/testsuite.src/run_fundamental.at b/gcc/cobol/UAT/testsuite.src/run_fundamental.at
index 481d77ef6bff..2b39f969c2a7 100644
--- a/gcc/cobol/UAT/testsuite.src/run_fundamental.at
+++ b/gcc/cobol/UAT/testsuite.src/run_fundamental.at
@@ -45,7 +45,6 @@ AT_DATA([prog.cob], [
END-DISPLAY.
STOP RUN.
])
-
AT_CHECK([$COMPILE prog.cob], [0], [], [])
AT_CHECK([./a.out], [0],
[12,3
@@ -5147,3 +5146,88 @@ argc is 08
], [])
AT_CLEANUP
+
+AT_SETUP([Named conditionals - fixed, float, and alphabetic])
+AT_KEYWORDS([named conditionals])
+AT_DATA([prog.cob], [ identification division.
+ program-id. prog.
+ data division.
+ working-storage section.
+ 01 makeofcar pic x(10).
+ 88 volksgroup value "skoda", "seat",
+ "audi", "volkswagen"
+ false "boat".
+ 88 germanmade value "volkswagen", "audi",
+ "mercedes", "bmw",
+ "porsche".
+ 01 agegroup pic 999.
+ 88 child value 0 through 12.
+ 88 teen value 13 through 19.
+ 88 adult value 20 through 999.
+ 01 floats float-long.
+ 88 neg value -1 through -.1 .
+ 88 zed value zero .
+ 88 pos value .1 through 1.0 .
+ procedure division.
+ move "ford" to makeofcar
+ display function trim (makeofcar)
+ if volksgroup display " volksgroup" end-if
+ if germanmade display " germanmade" end-if
+ move "skoda" to makeofcar
+ display function trim (makeofcar)
+ if volksgroup display " volksgroup" end-if
+ if germanmade display " germanmade" end-if
+ move "volkswagen" to makeofcar
+ display function trim (makeofcar)
+ if volksgroup display " volksgroup" end-if
+ if germanmade display " germanmade" end-if
+ move 5 to agegroup.
+ display agegroup with no advancing
+ if child display " child" end-if
+ if teen display " teen" end-if
+ if adult display " adult" end-if
+ move 15 to agegroup.
+ display agegroup with no advancing
+ if child display " child" end-if
+ if teen display " teen" end-if
+ if adult display " adult" end-if
+ move 75 to agegroup.
+ display agegroup with no advancing
+ if child display " child" end-if
+ if teen display " teen" end-if
+ if adult display " adult" end-if
+ move -0.5 to floats
+ display floats with no advancing
+ if neg display " minus" end-if
+ if zed display " zero" end-if
+ if pos display " plus" end-if
+ move zero to floats
+ display floats with no advancing
+ if neg display " minus" end-if
+ if zed display " zero" end-if
+ if pos display " plus" end-if
+ move 0.5 to floats
+ display floats with no advancing
+ if neg display " minus" end-if
+ if zed display " zero" end-if
+ if pos display " plus" end-if
+ continue.
+ quit.
+ goback.
+ end program prog.
+])
+AT_CHECK([$COMPILE prog.cob], [0], [], [])
+AT_CHECK([./a.out], [0], [ford
+skoda
+ volksgroup
+volkswagen
+ volksgroup
+ germanmade
+005 child
+015 teen
+075 adult
+-0.5 minus
+0 zero
+0.5 plus
+])
+AT_CLEANUP
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index 366d368ebe86..f267c45fe39f 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -3305,6 +3305,62 @@ compare_88( const char *list,
return cmpval;
}
+static _Float128
+get_float128( cblc_field_t *field,
+ unsigned char *location )
+ {
+ _Float128 retval=0;
+ if(field->type == FldFloat )
+ {
+ switch( field->capacity )
+ {
+ case 4:
+ retval = *(_Float32 *)location;
+ break;
+ case 8:
+ retval = *(_Float64 *)location;
+ break;
+ case 16:
+ // retval = *(_Float128 *)location; doesn't work, because the SSE
+ // registers need the source on a 16-byte boundary, and we can't
+ // guarantee that.
+ memcpy(&retval, location, 16);
+ break;
+ }
+ }
+ else if( field->type == FldLiteralN )
+ {
+ if( __gg__decimal_point == '.' )
+ {
+ retval = strtof128(field->initial, NULL);
+ }
+ else
+ {
+ // We need to replace any commas with periods
+ static size_t size = 128;
+ static char *buffer = (char *)malloc(size);
+ while( strlen(field->initial)+1 > size )
+ {
+ size *= 2;
+ buffer = (char *)malloc(size);
+ }
+ strcpy(buffer, field->initial);
+ char *p = strchr(buffer, ',');
+ if(p)
+ {
+ *p = '.';
+ }
+ retval = strtof128(buffer, NULL);
+ }
+ }
+ else
+ {
+ fprintf(stderr, "What's all this then?\n");
+ abort();
+ }
+ return retval;
+ }
+
static
int
compare_field_class(cblc_field_t *conditional,
@@ -3476,6 +3532,63 @@ compare_field_class(cblc_field_t *conditional,
break;
}
+ case FldFloat:
+ {
+ _Float128 value = get_float128(conditional, conditional_location) ;
+ char *walker = list->initial;
+ while(*walker)
+ {
+ char left_flag;
+ size_t left_len;
+ char * left;
+
+ char right_flag;
+ size_t right_len;
+ char * right;
+
+ char *pend;
+ left_len = strtoull(walker, &pend, 10);
+ left_flag = *pend;
+ left = pend+1;
+
+ right = left + left_len;
+ right_len = strtoull(right, &pend, 10);
+ right_flag = *pend;
+ right = pend+1;
+
+ walker = right + right_len;
+
+ _Float128 left_value;
+ if( left_flag == 'F' && left[0] == 'Z' )
+ {
+ left_value = 0;
+ }
+ else
+ {
+ left_value = __gg__dirty_to_float(left,
+ left_len);
+ }
+
+ _Float128 right_value;
+ if( right_flag == 'F' && right[0] == 'Z' )
+ {
+ right_value = 0;
+ }
+ else
+ {
+ right_value = __gg__dirty_to_float( right,
+ right_len);
+ }
+
+ if( left_value <= value && value <= right_value )
+ {
+ retval = 0;
+ break;
+ }
+ }
+ break;
+ }
+
default:
printf( "%s(): doesn't know what to do with %s\n",
__func__,
@@ -3624,64 +3737,6 @@ compare_strings(char *left_string,
return retval;
}
-
-
-static _Float128
-get_float128( cblc_field_t *field,
- unsigned char *location )
- {
- _Float128 retval=0;
- if(field->type == FldFloat )
- {
- switch( field->capacity )
- {
- case 4:
- retval = *(_Float32 *)location;
- break;
- case 8:
- retval = *(_Float64 *)location;
- break;
- case 16:
- // retval = *(_Float128 *)location; doesn't work, because the SSE
- // registers need the source on a 16-byte boundary, and we can't
- // guarantee that.
- memcpy(&retval, location, 16);
- break;
- }
- }
- else if( field->type == FldLiteralN )
- {
- if( __gg__decimal_point == '.' )
- {
- retval = strtof128(field->initial, NULL);
- }
- else
- {
- // We need to replace any commas with periods
- static size_t size = 128;
- static char *buffer = (char *)malloc(size);
- while( strlen(field->initial)+1 > size )
- {
- size *= 2;
- buffer = (char *)malloc(size);
- }
- strcpy(buffer, field->initial);
- char *p = strchr(buffer, ',');
- if(p)
- {
- *p = '.';
- }
- retval = strtof128(buffer, NULL);
- }
- }
- else
- {
- fprintf(stderr, "What's all this then?\n");
- abort();
- }
- return retval;
- }
-
extern "C"
int
__gg__compare_2(cblc_field_t *left_side,
--
GitLab