cobol: Improved handling of COBOL Special Registers.

COBOL Special Registers (e.g., RETURN-CODE; DEBUG-ITEM) are implemented as
global variables.  These changes define them with the prefix "__ggsr__" in
their variable names so that the GDB-COBOL debugger can identify them.

The creation and handling of such variables has been streamlined with the
introduction of the "register_e" cbl_field_t::attr bit.

gcc/cobol/ChangeLog:

	* genapi.cc (trace1_init): Prepend two internal variables with
	underscore.
	(initialize_variable_internal): Use new register_e attribute.
	(psa_global): Use "__ggsr__" prefix to identify special registers
	(parser_symbol_add): Use new register_e attribute.
	* symbols.cc (cbl_field_attr_str): Likewise.
	(symbol_table_init): Likewise.
	(is_register_field): Eliminated in favor of (attr & register_e).
	* symbols.h (is_register_field): Likewise.

libgcobol/ChangeLog:

	* common-defs.h (enum cbl_field_attr_t): Define register_e.
	* constants.cc (struct cblc_field_t): Define special registers with
	"__ggsr__" prefix.

3 files changed, 52 insertions, 73 deletions

diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index 40b79ba..11242c1 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -203,8 +203,8 @@ trace1_init()
   if( first_time )
     {
     first_time = false;
-    trace_handle = gg_define_variable(INT, "trace_handle", vs_static);
-    trace_indent = gg_define_variable(INT, "trace_indent", vs_static);
+    trace_handle = gg_define_variable(INT, "_trace_handle", vs_static);
+    trace_indent = gg_define_variable(INT, "_trace_indent", vs_static);
 
     bTRACE1 = getenv("GCOBOL_TRACE") ? getenv("GCOBOL_TRACE") :gv_trace_switch;
 
@@ -1227,7 +1227,7 @@ initialize_variable_internal( cbl_refer_t refer,
     return;
     }
 
-  if( is_register_field( parsed_var) )
+  if( parsed_var->attr & register_e )
     {
     return;
     }
@@ -16374,10 +16374,6 @@ actually_create_the_static_field( cbl_field_t *new_var,
 static void
 psa_global(cbl_field_t *new_var)
   {
-  char *mname = cobol_name_mangler(new_var->name);
-  char ach[2*sizeof(cbl_name_t)];
-  sprintf(ach, "__gg__%s", mname);
-  free(mname);
 
   if( strcmp(new_var->name, "_VERY_TRUE") == 0 )
     {
@@ -16390,10 +16386,20 @@ psa_global(cbl_field_t *new_var)
     return;
     }
 
-  // global variables already have a cblc_field_t defined in constants.cc
+  // global variables already have a cblc_field_t defined in constants.cc.
 
-  strcpy(ach, "__gg__");
-  strcat(ach, new_var->name);
+  // Finding their name is done by converting to lowercase, dashes become
+  // underscores, and "__ggsr__" is prepended.  "filler" gets ignored.
+
+  // To feed GDB-COBOL's requirements, we tack on this variable's index and
+  // this program's index number:
+
+  char ach[2*sizeof(cbl_name_t)];
+
+  snprintf( ach,
+            sizeof(ach),
+            "__ggsr__%s",
+            new_var->name);
   for(size_t i=0; i<strlen(ach); i++)
     {
     ach[i] = _tolower(ach[i]);
@@ -16403,16 +16409,6 @@ psa_global(cbl_field_t *new_var)
       }
     }
 
-  if( strcmp(new_var->name, "RETURN-CODE") == 0 )
-    {
-    strcpy(ach, "__gg__return_code");
-    }
-
-  if( strcmp(new_var->name, "UPSI-0") == 0 )
-    {
-    strcpy(ach, "__gg__upsi");
-    }
-
   new_var->var_decl_node = gg_declare_variable(cblc_field_type_node, ach, NULL, vs_external_reference);
 
   // global variables already have a .data area defined.  We can find that
@@ -16857,7 +16853,7 @@ parser_symbol_add(struct cbl_field_t *new_var )
     {
     cbl_field_type_t incoming_type = new_var->type;
 
-    if( is_register_field(new_var) )
+    if( new_var->attr & register_e )
       {
       psa_global(new_var);
       goto done;
diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc
index bbe99b6..205465b 100644
--- a/gcc/cobol/symbols.cc
+++ b/gcc/cobol/symbols.cc
@@ -741,7 +741,7 @@ cbl_field_attr_str( cbl_field_attr_t attr ) {
   case function_e: return "function";
   case quoted_e: return "quoted";
   case filler_e: return "filler";
-  case _spare_e: return "temporary";
+  case register_e: return "register";
   case intermediate_e: return "intermediate";
   case embiggened_e: return "embiggened";
   case all_alpha_e: return "all_alpha";
@@ -2153,34 +2153,34 @@ symbol_table_init(void) {
 
   // These should match the definitions in libgcobol/constants.cc
   static cbl_field_t constants[] = {
-    { 0, FldAlphanumeric, FldInvalid, space_value_e | constq, 0, 0, 0, nonarray, 0,
+    { 0, FldAlphanumeric, FldInvalid, space_value_e | constq | register_e, 0, 0, 0, nonarray, 0,
       "SPACE", 0, {}, {1,1,0,0, " \0\xFF"}, NULL },
-    { 0, FldAlphanumeric, FldInvalid, space_value_e | constq , 0, 0, 0, nonarray, 0,
+    { 0, FldAlphanumeric, FldInvalid, space_value_e | constq | register_e, 0, 0, 0, nonarray, 0,
       "SPACES", 0, {}, {1,1,0,0, " \0\xFF"}, NULL },
-    { 0, FldAlphanumeric, FldInvalid, low_value_e | constq, 0, 0, 0, nonarray, 0,
+    { 0, FldAlphanumeric, FldInvalid, low_value_e | constq | register_e, 0, 0, 0, nonarray, 0,
       "LOW_VALUES", 0, {}, {1,1,0,0, "L\0\xFF"}, NULL },
-    { 0, FldAlphanumeric, FldInvalid, zero_value_e | constq, 0, 0, 0, nonarray, 0,
+    { 0, FldAlphanumeric, FldInvalid, zero_value_e | constq | register_e, 0, 0, 0, nonarray, 0,
       "ZEROS", 0, {}, {1,1,0,0, "0"}, NULL },
-    { 0, FldAlphanumeric, FldInvalid, high_value_e | constq, 0, 0, 0, nonarray, 0,
+    { 0, FldAlphanumeric, FldInvalid, high_value_e | constq | register_e, 0, 0, 0, nonarray, 0,
       "HIGH_VALUES", 0, {}, {1,1,0,0, "H\0\xFF"}, NULL },
     // IBM standard: QUOTE is a double-quote unless APOST compiler option
-    { 0, FldAlphanumeric, FldInvalid, quote_value_e | constq , 0, 0, 0, nonarray, 0,
+    { 0, FldAlphanumeric, FldInvalid, quote_value_e | constq | register_e , 0, 0, 0, nonarray, 0,
       "QUOTES", 0, {}, {1,1,0,0, "\"\0\xFF"}, NULL },
-    { 0, FldPointer, FldPointer, constq , 0, 0, 0, nonarray, 0,
+    { 0, FldPointer, FldPointer, constq | register_e , 0, 0, 0, nonarray, 0,
       "NULLS", 0, {}, {8,8,0,0, zeroes_for_null_pointer}, NULL },
     // IBM defines TALLY
     // 01  TALLY GLOBAL PICTURE 9(5) USAGE BINARY VALUE ZERO.
-    { 0, FldNumericBin5, FldInvalid, signable_e, 0, 0, 0, nonarray, 0,
+    { 0, FldNumericBin5, FldInvalid, signable_e | register_e, 0, 0, 0, nonarray, 0,
       "_TALLY", 0, {}, {16, 16, MAX_FIXED_POINT_DIGITS, 0, NULL}, NULL },
     // 01  ARGI is the current index into the argv array
-    { 0, FldNumericBin5, FldInvalid, signable_e, 0, 0, 0, nonarray, 0,
+    { 0, FldNumericBin5, FldInvalid, signable_e | register_e, 0, 0, 0, nonarray, 0,
       "_ARGI", 0, {}, {16, 16, MAX_FIXED_POINT_DIGITS, 0, NULL}, NULL },
 
     // These last two don't require actual storage; they get BOOL var_decl_node
     // in parser_symbol_add()
-    { 0, FldConditional, FldInvalid, constant_e , 0, 0, 0, nonarray, 0,
+    { 0, FldConditional, FldInvalid, constant_e | register_e , 0, 0, 0, nonarray, 0,
       "_VERY_TRUE", 0, {}, {1,1,0,0, ""}, NULL },
-    { 0, FldConditional, FldInvalid, constant_e , 0, 0, 0, nonarray, 0,
+    { 0, FldConditional, FldInvalid, constant_e | register_e , 0, 0, 0, nonarray, 0,
       "_VERY_FALSE", 0, {}, {1,1,0,0, ""}, NULL },
   };
   for( struct cbl_field_t *f = constants;
@@ -2253,29 +2253,29 @@ symbol_table_init(void) {
    **/
 
   static cbl_field_t debug_registers[] = {
-    { 0, FldGroup, FldInvalid, global_e, 0,0,1, nonarray, 0,
+    { 0, FldGroup, FldInvalid, register_e, 0,0,1, nonarray, 0,
       "DEBUG-ITEM", 0, {}, {132,132,0,0, NULL}, NULL },
-    { 0, FldAlphanumeric, FldInvalid, global_e, 0,0,2, nonarray, 0,
+    { 0, FldAlphanumeric, FldInvalid, register_e, 0,0,2, nonarray, 0,
       "DEBUG-LINE", 0, {}, {6,6,0,0, "      "}, NULL },
-    { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
+    { 0, FldAlphanumeric, FldInvalid, register_e|filler_e, 0,0,2, nonarray, 0,
       "FILLER", 0, {}, {1,1,0,0, " "}, NULL },
-    { 0, FldAlphanumeric, FldInvalid, global_e, 0,0,2, nonarray, 0,
+    { 0, FldAlphanumeric, FldInvalid, register_e, 0,0,2, nonarray, 0,
       "DEBUG-NAME", 0, {}, {30,30,0,0, NULL}, NULL },
-    { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
+    { 0, FldAlphanumeric, FldInvalid, register_e|filler_e, 0,0,2, nonarray, 0,
       "FILLER", 0, {}, {1,1,0,0, " "}, NULL },
-    { 0, FldNumericDisplay, FldInvalid, signable_e | global_e | leading_e | separate_e, 0,0,2, nonarray, 0,
-      "DEBUG-SUB-1", 0, {}, {5,5,3,0, NULL}, NULL },
-    { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
+    { 0, FldNumericDisplay, FldInvalid, signable_e | register_e | leading_e | separate_e, 0,0,2, nonarray, 0,
+      "DEBUG-SUB-1", 0, {}, {5,5,4,0, NULL}, NULL },
+    { 0, FldAlphanumeric, FldInvalid, register_e|filler_e, 0,0,2, nonarray, 0,
       "FILLER", 0, {}, {1,1,0,0, " "}, NULL },
-    { 0, FldNumericDisplay, FldInvalid, signable_e | global_e | leading_e | separate_e, 0,0,2, nonarray, 0,
-      "DEBUG-SUB-2", 0, {}, {5,5,3,0, NULL}, NULL },
-    { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
+    { 0, FldNumericDisplay, FldInvalid, signable_e | register_e | leading_e | separate_e, 0,0,2, nonarray, 0,
+      "DEBUG-SUB-2", 0, {}, {5,5,4,0, NULL}, NULL },
+    { 0, FldAlphanumeric, FldInvalid, register_e|filler_e, 0,0,2, nonarray, 0,
       "FILLER", 0, {}, {1,1,0,0, " "}, NULL },
-    { 0, FldNumericDisplay, FldInvalid, signable_e | global_e | leading_e | separate_e, 0,0,2, nonarray, 0,
-      "DEBUG-SUB-3", 0, {}, {5,5,3,0, NULL}, NULL },
-    { 0, FldAlphanumeric, FldInvalid, 0, 0,0,2, nonarray, 0,
+    { 0, FldNumericDisplay, FldInvalid, signable_e | register_e | leading_e | separate_e, 0,0,2, nonarray, 0,
+      "DEBUG-SUB-3", 0, {}, {5,5,4,0, NULL}, NULL },
+    { 0, FldAlphanumeric, FldInvalid, register_e|filler_e, 0,0,2, nonarray, 0,
       "FILLER", 0, {}, {1,1,0,0, " "}, NULL },
-    { 0, FldAlphanumeric, FldInvalid, signable_e | global_e, 0,0,2, nonarray, 0,
+    { 0, FldAlphanumeric, FldInvalid, signable_e | register_e, 0,0,2, nonarray, 0,
       "DEBUG-CONTENTS", 0, {}, {76,76,0,0, NULL}, NULL },
   };
 
@@ -2296,21 +2296,21 @@ symbol_table_init(void) {
   std::for_each(debug_start+1, p, parent_elem_set(debug_start - table.elems));
 
   static cbl_field_t special_registers[] = {
-    { 0, FldNumericDisplay, FldInvalid, 0, 0, 0, 0, nonarray, 0, "_FILE_STATUS",
+    { 0, FldNumericDisplay, FldInvalid, register_e, 0, 0, 0, nonarray, 0, "_FILE_STATUS",
       0, {}, {2,2,2,0, NULL}, NULL },
-    { 0, FldNumericBin5, FldInvalid, 0, 0, 0, 0, nonarray, 0, "UPSI-0",
+    { 0, FldNumericBin5, FldInvalid, register_e, 0, 0, 0, nonarray, 0, "UPSI-0",
       0, {}, {2,2,4,0, NULL}, NULL },
-    { 0, FldNumericBin5, FldInvalid, signable_e, 0, 0, 0, nonarray, 0, "RETURN-CODE",
+    { 0, FldNumericBin5, FldInvalid, signable_e|register_e, 0, 0, 0, nonarray, 0, "RETURN-CODE",
       0, {}, {2,2,4,0, NULL}, NULL },
-    { 0, FldNumericBin5, FldInvalid, 0, 0, 0, 0, nonarray, 0, "LINAGE-COUNTER",
+    { 0, FldNumericBin5, FldInvalid, register_e, 0, 0, 0, nonarray, 0, "LINAGE-COUNTER",
       0, {}, {2,2,4,0, NULL}, NULL },
-    { 0, FldLiteralA, FldInvalid, 0, 0, 0, 0, nonarray, 0, "_dev_stdin",
+    { 0, FldLiteralA, FldInvalid, register_e, 0, 0, 0, nonarray, 0, "_dev_stdin",
       0, {}, {0,0,0,0, "/dev/stdin"}, NULL },
-    { 0, FldLiteralA, FldInvalid, constq, 0, 0, 0, nonarray, 0, "_dev_stdout",
+    { 0, FldLiteralA, FldInvalid, constq|register_e, 0, 0, 0, nonarray, 0, "_dev_stdout",
       0, {}, {0,0,0,0, "/dev/stdout"}, NULL },
-    { 0, FldLiteralA, FldInvalid, constq, 0, 0, 0, nonarray, 0, "_dev_stderr",
+    { 0, FldLiteralA, FldInvalid, constq|register_e, 0, 0, 0, nonarray, 0, "_dev_stderr",
       0, {}, {0,0,0,0, "/dev/stderr"}, NULL },
-    { 0, FldLiteralA, FldInvalid, constq, 0, 0, 0, nonarray, 0, "_dev_null",
+    { 0, FldLiteralA, FldInvalid, constq|register_e, 0, 0, 0, nonarray, 0, "_dev_null",
       0, {}, {0,0,0,0, "/dev/null"}, NULL },
   };
 
@@ -4713,21 +4713,6 @@ ast_file_status_between( file_status_t lower, file_status_t upper ) {
 }
 
 bool
-is_register_field(const cbl_field_t *field)
-  {
-  // TRUE when the field is an executable-level global variable of the type we
-  // are calling a "register", like RETURN-CODE or UPSI or the like:
-  return
-    (    field->parent == 0
-      && field->level == 0
-      && !(field->attr & intermediate_e)
-      && !(field->attr & filler_e)
-      && field->type != FldClass
-      && field->type != FldBlob
-      );
-  }
-
-bool
 has_value( cbl_field_type_t type ) {
   // Indicates that the field type contains data that can be expressed as
   // a numeric value
diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h
index c8ae32f..c8b37a6 100644
--- a/gcc/cobol/symbols.h
+++ b/gcc/cobol/symbols.h
@@ -817,8 +817,6 @@ is_record_area( const cbl_field_t *field ) {
   return 0 == memcmp(field->name, stem, sizeof(stem)-1);
 }
 
-bool is_register_field( const cbl_field_t *field );
-
 static inline bool
 is_constant( const cbl_field_t *field ) {
   return field->has_attr(constant_e);