cobol: Proper comparison of alphanumeric to refmoded numeric-display [PR119682]

gcc/cobol

	PR cobol/119682
	* genapi.cc: (cobol_compare): Change the call to __gg__compare().

libgcobol

	PR cobol/119682
	* common-defs.h: Define the REFER_T_REFMOD constant.
	* intrinsic.cc: (__gg__max): Change the calls to __gg__compare_2(),
	(__gg__min): Likewise, (__gg__ord_min): Likewise,
	(__gg__ord_max): Likewise.
	* libgcobol.cc: (__gg__compare_2): Change definition of calling
	parameters, eliminate separate flag bit for ALL and ADDRESS_OF,
	change comparison of alphanumeric to numeric when the numeric
	is a refmod.
	* libgcobol.h: Change declaration of __gg__compare_2.

5 files changed, 77 insertions, 86 deletions

diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index c91237b..fdf76aa 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -2028,10 +2028,12 @@ cobol_compare(  tree return_int,
     {
     // None of our explicit comparisons up above worked, so we revert to the
     // general case:
-    int leftflags  =   (left_side_ref.all      ? REFER_T_MOVE_ALL : 0)
-                    +  (left_side_ref.addr_of  ? REFER_T_ADDRESS_OF : 0);
-    int rightflags =   (right_side_ref.all     ? REFER_T_MOVE_ALL : 0)
-                    +  (right_side_ref.addr_of ? REFER_T_ADDRESS_OF : 0);
+    int leftflags  =   (left_side_ref.all          ? REFER_T_MOVE_ALL   : 0)
+                    +  (left_side_ref.addr_of      ? REFER_T_ADDRESS_OF : 0)
+                    +  (left_side_ref.refmod.from  ? REFER_T_REFMOD     : 0);
+    int rightflags =   (right_side_ref.all         ? REFER_T_MOVE_ALL   : 0)
+                    +  (right_side_ref.addr_of     ? REFER_T_ADDRESS_OF : 0)
+                    +  (right_side_ref.refmod.from ? REFER_T_REFMOD     : 0);
     gg_assign(  return_int, gg_call_expr(
                 INT,
                 "__gg__compare",
@@ -2045,6 +2047,7 @@ cobol_compare(  tree return_int,
                 build_int_cst_type(INT, rightflags),
                 integer_zero_node,
                 NULL_TREE));
+    compared = true;
     }
 
 //  gg_printf("   result is %d\n", return_int, NULL_TREE);
diff --git a/libgcobol/common-defs.h b/libgcobol/common-defs.h
index f9d9c56..6bf32ef 100644
--- a/libgcobol/common-defs.h
+++ b/libgcobol/common-defs.h
@@ -70,6 +70,7 @@
 #define REFER_T_ALL_FLAGS_MASK 0x0FF  // We allow for seven subscripts
 #define REFER_T_MOVE_ALL       0x100  // This is the move_all flag
 #define REFER_T_ADDRESS_OF     0x200  // This is the address_of flag
+#define REFER_T_REFMOD         0x400  // Indicates to library the refer was a refmod
 
 #define MIN_FIELD_BLOCK_SIZE (16)
 
diff --git a/libgcobol/intrinsic.cc b/libgcobol/intrinsic.cc
index 4bce481..e0bd333 100644
--- a/libgcobol/intrinsic.cc
+++ b/libgcobol/intrinsic.cc
@@ -1867,8 +1867,7 @@ __gg__max(cblc_field_t *dest,
     unsigned char *best_location   ;
     size_t         best_length     ;
     int            best_attr       ;
-    bool           best_move_all   ;
-    bool           best_address_of ;
+    int            best_flags      ;
 
     bool first_time = true;
     assert(ncount);
@@ -1887,8 +1886,7 @@ __gg__max(cblc_field_t *dest,
           best_location   = __gg__treeplet_1f[i]->data + __gg__treeplet_1o[i];
           best_length     = __gg__treeplet_1s[i];
           best_attr       = __gg__treeplet_1f[i]->attr;
-          best_move_all   = !!(__gg__fourplet_flags[i] & REFER_T_MOVE_ALL);
-          best_address_of = !!(__gg__fourplet_flags[i] & REFER_T_ADDRESS_OF);
+          best_flags      = __gg__fourplet_flags[i];
           }
         else
           {
@@ -1896,31 +1894,27 @@ __gg__max(cblc_field_t *dest,
           unsigned char *candidate_location   = __gg__treeplet_1f[i]->data + __gg__treeplet_1o[i];
           size_t         candidate_length     = __gg__treeplet_1s[i];
           int            candidate_attr       = __gg__treeplet_1f[i]->attr;
-          bool           candidate_move_all   = !!(__gg__fourplet_flags[i] & REFER_T_MOVE_ALL);
-          bool           candidate_address_of = !!(__gg__fourplet_flags[i] & REFER_T_ADDRESS_OF);
+          int            candidate_flags      = __gg__fourplet_flags[i];
 
           int compare_result = __gg__compare_2(
                                  candidate_field,
                                  candidate_location,
                                  candidate_length,
                                  candidate_attr,
-                                 candidate_move_all,
-                                 candidate_address_of,
+                                 candidate_flags,
                                  best_field,
                                  best_location,
                                  best_length,
                                  best_attr,
-                                 best_move_all,
-                                 best_address_of,
+                                 best_flags,
                                  0);
           if( compare_result >= 0 )
             {
-            best_field      = candidate_field    ;
-            best_location   = candidate_location ;
-            best_length     = candidate_length   ;
-            best_attr       = candidate_attr     ;
-            best_move_all   = candidate_move_all ;
-            best_address_of = candidate_address_of ;
+            best_field      = candidate_field      ;
+            best_location   = candidate_location   ;
+            best_length     = candidate_length     ;
+            best_attr       = candidate_attr       ;
+            best_flags      = candidate_flags      ;
             }
           }
         if( !update_refer_state_for_all(state, __gg__treeplet_1f[i]) )
@@ -2129,8 +2123,7 @@ __gg__min(cblc_field_t *dest,
     unsigned char *best_location   ;
     size_t         best_length     ;
     int            best_attr       ;
-    bool           best_move_all   ;
-    bool           best_address_of ;
+    int            best_flags      ;
 
     bool first_time = true;
     assert(ncount);
@@ -2149,8 +2142,7 @@ __gg__min(cblc_field_t *dest,
           best_location   = __gg__treeplet_1f[i]->data + __gg__treeplet_1o[i];
           best_length     = __gg__treeplet_1s[i];
           best_attr       = __gg__treeplet_1f[i]->attr;
-          best_move_all   = !!(__gg__fourplet_flags[i] & REFER_T_MOVE_ALL);
-          best_address_of = !!(__gg__fourplet_flags[i] & REFER_T_ADDRESS_OF);
+          best_flags      = __gg__fourplet_flags[i];
           }
         else
           {
@@ -2158,31 +2150,27 @@ __gg__min(cblc_field_t *dest,
           unsigned char *candidate_location   = __gg__treeplet_1f[i]->data + __gg__treeplet_1o[i];
           size_t         candidate_length     = __gg__treeplet_1s[i];
           int            candidate_attr       = __gg__treeplet_1f[i]->attr;
-          bool           candidate_move_all   = !!(__gg__fourplet_flags[i] & REFER_T_MOVE_ALL);
-          bool           candidate_address_of = !!(__gg__fourplet_flags[i] & REFER_T_ADDRESS_OF);
+          int            candidate_flags      = __gg__fourplet_flags[i];
 
           int compare_result = __gg__compare_2(
                                  candidate_field,
                                  candidate_location,
                                  candidate_length,
                                  candidate_attr,
-                                 candidate_move_all,
-                                 candidate_address_of,
+                                 candidate_flags,
                                  best_field,
                                  best_location,
                                  best_length,
                                  best_attr,
-                                 best_move_all,
-                                 best_address_of,
+                                 best_flags,
                                  0);
           if( compare_result < 0 )
             {
-            best_field      = candidate_field    ;
-            best_location   = candidate_location ;
-            best_length     = candidate_length   ;
-            best_attr       = candidate_attr     ;
-            best_move_all   = candidate_move_all ;
-            best_address_of = candidate_address_of ;
+            best_field      = candidate_field      ;
+            best_location   = candidate_location   ;
+            best_length     = candidate_length     ;
+            best_attr       = candidate_attr       ;
+            best_flags      = candidate_flags      ;
             }
           }
         if( !update_refer_state_for_all(state, __gg__treeplet_1f[i]) )
@@ -2991,14 +2979,12 @@ __gg__ord_min(cblc_field_t *dest,
   unsigned char *best_location;
   size_t         best_length;
   int            best_attr;
-  bool           best_move_all;
-  bool           best_address_of ;
+  int            best_flags;
 
   unsigned char  *candidate_location;
   size_t candidate_length;
   int    candidate_attr;
-  bool   candidate_move_all;
-  bool   candidate_address_of;
+  int    candidate_flags;
 
   for( size_t i=0; i<ninputs; i++ )
     {
@@ -3016,8 +3002,7 @@ __gg__ord_min(cblc_field_t *dest,
         best_location   = __gg__treeplet_1f[i]->data + __gg__treeplet_1o[i];
         best_length     = __gg__treeplet_1s[i];
         best_attr       = __gg__treeplet_1f[i]->attr;
-        best_move_all   = !!(__gg__fourplet_flags[i] & REFER_T_MOVE_ALL);
-        best_address_of = !!(__gg__fourplet_flags[i] & REFER_T_ADDRESS_OF);
+        best_flags      = __gg__fourplet_flags[i];
         }
       else
         {
@@ -3026,8 +3011,7 @@ __gg__ord_min(cblc_field_t *dest,
         candidate_location   = __gg__treeplet_1f[i]->data + __gg__treeplet_1o[i];
         candidate_length     = __gg__treeplet_1s[i];
         candidate_attr       = __gg__treeplet_1f[i]->attr;
-        candidate_move_all   = !!(__gg__fourplet_flags[i] & REFER_T_MOVE_ALL);
-        candidate_address_of = !!(__gg__fourplet_flags[i] & REFER_T_ADDRESS_OF);
+        candidate_flags      = __gg__fourplet_flags[i];
 
         int compare_result =
           __gg__compare_2(
@@ -3035,14 +3019,12 @@ __gg__ord_min(cblc_field_t *dest,
             candidate_location,
             candidate_length,
             candidate_attr,
-            candidate_move_all,
-            candidate_address_of,
+            candidate_flags,
             best,
             best_location,
             best_length,
             best_attr,
-            best_move_all,
-            best_address_of,
+            best_flags,
             0);
         if( compare_result < 0 )
           {
@@ -3051,8 +3033,7 @@ __gg__ord_min(cblc_field_t *dest,
           best_location   = candidate_location;
           best_length     = candidate_length;
           best_attr       = candidate_attr;
-          best_move_all   = candidate_move_all;
-          best_address_of = candidate_address_of;
+          best_flags      = candidate_flags;
           }
         }
       if( !update_refer_state_for_all(state, __gg__treeplet_1f[i]) )
@@ -3086,14 +3067,12 @@ __gg__ord_max(cblc_field_t *dest,
   unsigned char *best_location;
   size_t         best_length;
   int            best_attr;
-  bool           best_move_all;
-  bool           best_address_of ;
+  int            best_flags;
 
   unsigned char  *candidate_location;
   size_t candidate_length;
   int    candidate_attr;
-  bool   candidate_move_all;
-  bool   candidate_address_of;
+  int    candidate_flags;
 
   for( size_t i=0; i<ninputs; i++ )
     {
@@ -3111,8 +3090,7 @@ __gg__ord_max(cblc_field_t *dest,
         best_location   = __gg__treeplet_1f[i]->data + __gg__treeplet_1o[i];
         best_length     = __gg__treeplet_1s[i];
         best_attr       = __gg__treeplet_1f[i]->attr;
-        best_move_all   = !!(__gg__fourplet_flags[i] & REFER_T_MOVE_ALL);
-        best_address_of = !!(__gg__fourplet_flags[i] & REFER_T_ADDRESS_OF);
+        best_flags      = __gg__fourplet_flags[i];
         }
       else
         {
@@ -3121,8 +3099,7 @@ __gg__ord_max(cblc_field_t *dest,
         candidate_location   = __gg__treeplet_1f[i]->data + __gg__treeplet_1o[i];
         candidate_length     = __gg__treeplet_1s[i];
         candidate_attr       = __gg__treeplet_1f[i]->attr;
-        candidate_move_all   = !!(__gg__fourplet_flags[i] & REFER_T_MOVE_ALL);
-        candidate_address_of = !!(__gg__fourplet_flags[i] & REFER_T_ADDRESS_OF);
+        candidate_flags      = __gg__fourplet_flags[i];
 
         int compare_result =
           __gg__compare_2(
@@ -3130,14 +3107,12 @@ __gg__ord_max(cblc_field_t *dest,
             candidate_location,
             candidate_length,
             candidate_attr,
-            candidate_move_all,
-            candidate_address_of,
+            candidate_flags,
             best,
             best_location,
             best_length,
             best_attr,
-            best_move_all,
-            best_address_of,
+            best_flags,
             0);
         if( compare_result > 0 )
           {
@@ -3146,8 +3121,7 @@ __gg__ord_max(cblc_field_t *dest,
           best_location   = candidate_location;
           best_length     = candidate_length;
           best_attr       = candidate_attr;
-          best_move_all   = candidate_move_all;
-          best_address_of = candidate_address_of;
+          best_flags      = candidate_flags;
           }
         }
       if( !update_refer_state_for_all(state, __gg__treeplet_1f[i]) )
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index c163e2c..f7fa7a7 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -3919,23 +3919,17 @@ __gg__compare_2(cblc_field_t *left_side,
                 unsigned char   *left_location,
                 size_t  left_length,
                 int     left_attr,
-                bool    left_all,
-                bool    left_address_of,
+                int     left_flags,
                 cblc_field_t *right_side,
                 unsigned char   *right_location,
                 size_t  right_length,
                 int     right_attr,
-                bool    right_all,
-                bool    right_address_of,
+                int     right_flags,
                 int     second_time_through)
   {
   // First order of business:  If right_side is a FldClass, pass that off
   // to the speciality squad:
 
-  // static size_t converted_initial_size = MINIMUM_ALLOCATION_SIZE;
-  // static unsigned char *converted_initial =
-                                // (unsigned char *)malloc(converted_initial_size);
-
   if( right_side->type == FldClass )
     {
     return compare_field_class( left_side,
@@ -3945,8 +3939,17 @@ __gg__compare_2(cblc_field_t *left_side,
     }
 
   // Serene in our conviction that the left_side isn't a FldClass, we
-  // move on:
+  // move on.
+
+  // Extract the individual flags from the flag words:
+  bool left_all         = !!(left_flags  & REFER_T_MOVE_ALL  );
+  bool left_address_of  = !!(left_flags  & REFER_T_ADDRESS_OF);
+  bool right_all        = !!(right_flags & REFER_T_MOVE_ALL  );
+  bool right_address_of = !!(right_flags & REFER_T_ADDRESS_OF);
+//bool left_refmod      = !!(left_flags  & REFER_T_REFMOD    );
+  bool right_refmod     = !!(right_flags & REFER_T_REFMOD    );
 
+  // Figure out if we have any figurative constants
   cbl_figconst_t left_figconst  = (cbl_figconst_t)(left_attr  & FIGCONST_MASK);
   cbl_figconst_t right_figconst = (cbl_figconst_t)(right_attr & FIGCONST_MASK);
 
@@ -4302,6 +4305,23 @@ __gg__compare_2(cblc_field_t *left_side,
       {
       // We are comparing an alphanumeric to a numeric.
 
+      // The right side is numeric.  Sometimes people write code where they
+      // take the refmod of a numeric displays.  If somebody did that here,
+      // just do a complete straight-up character by character comparison:
+      
+      if( right_refmod )
+        {
+        retval = compare_strings(   (char *)left_location,
+                                    left_length,
+                                    left_all,
+                                    (char *)right_location,
+                                    right_length,
+                                    right_all);
+        compare = true;
+        goto fixup_retval;
+        }
+
+
       // The trick here is to convert the numeric to its display form,
       // and compare that to the alphanumeric. For example, when comparing
       // a VAL5 PIC X(3) VALUE 5 to literals,
@@ -4310,7 +4330,6 @@ __gg__compare_2(cblc_field_t *left_side,
       // VAL5 EQUAL  005  is TRUE
       // VAL5 EQUAL   "5" is FALSE
       // VAL5 EQUAL "005" is TRUE
-
       if( left_side->type == FldLiteralA )
         {
         left_location = (unsigned char *)left_side->data;
@@ -4373,14 +4392,12 @@ fixup_retval:
                                 right_location,
                                 right_length,
                                 right_attr,
-                                right_all,
-                                right_address_of,
+                                right_flags,
                                 left_side,
                                 left_location,
                                 left_length,
                                 left_attr,
-                                left_all,
-                                left_address_of,
+                                left_flags,
                                 1);
     // And reverse the sense of the return value:
     compare = true;
@@ -4428,14 +4445,12 @@ __gg__compare(struct cblc_field_t *left,
                             left->data + left_offset,
                             left_length,
                             left->attr,
-                            !!(left_flags & REFER_T_MOVE_ALL),
-                            !!(left_flags & REFER_T_ADDRESS_OF),
+                            left_flags,
                             right,
                             right->data + right_offset,
                             right_length,
                             right->attr,
-                            !!(right_flags & REFER_T_MOVE_ALL),
-                            !!(right_flags & REFER_T_ADDRESS_OF),
+                            right_flags,
                             second_time_through);
   return retval;
   }
diff --git a/libgcobol/libgcobol.h b/libgcobol/libgcobol.h
index 1fc7abc..246ef51 100644
--- a/libgcobol/libgcobol.h
+++ b/libgcobol/libgcobol.h
@@ -54,14 +54,12 @@ extern "C" int __gg__compare_2( cblc_field_t *left_side,
                                 unsigned char   *left_location,
                                 size_t  left_length,
                                 int     left_attr,
-                                bool    left_all,
-                                bool    left_address_of,
+                                int     left_flags,
                                 cblc_field_t *right_side,
                                 unsigned char   *right_location,
                                 size_t  right_length,
                                 int     right_attr,
-                                bool    right_all,
-                                bool    right_address_of,
+                                int     right_flags,
                                 int     second_time_through);
 extern "C" void __gg__int128_to_field(cblc_field_t   *tgt,
                                       __int128        value,