cobol: Introduce vendor-compatibility layer as user-defined functions.

Install COBOL UDFs in a target directory that includes the GCC version
in its path, to permit side-by-side installation. Support compat
library with COBOL POSIX bindings; support those binding with C
functions in libgcobol as needed.

Changes to the compiler to support POSIX binding and testing.

Include developer conveniences -- Makefiles, bin/ and t/ directories --
to ensure UDFs compile and return reasonable results.  These are
not installed and do not affect how libgcobol is built.

gcc/cobol/ChangeLog:

	* cdf.y: Install literals in symbol table.
	* genapi.cc (parser_alphabet): Use std::string for currency.
	(initialize_the_data): Rely on constructor.
	(parser_file_add): Better #pragma message.
	(parser_exception_file): Return early if not generating code.
	* parse.y: Allow library programs to act as functions.
	* parse_ante.h (dialect_proscribed): Standardize message.
	(intrinsic_call_2): Correct s/fund/func/ misspelling.
	* scan.l: Comment.
	* symbols.cc (symbols_update): Add unreachable assertion.
	(symbol_field_parent_set): Reduce error to debug message.
	(cdf_literalize): Declare.
	(symbol_table_init): Insert CDF constants as literals.
	* symbols.h (cbl_dialect_str): Provide string values for enum.
	(is_working_storage): Remove function.
	(struct cbl_field_data_t): Add manhandle_initial for Numeric Edited.
	(struct cbl_field_t): Initialize name to zeros.
	(struct cbl_section_t): Delete unused attr() function.
	(symbol_unique_index): Declare.
	* token_names.h: Regenerate.
	* util.cc (cdf_literalize): Construct a cbl_field_t from a CDF literal.
	(symbol_unique_index): Supply "globally" unique number for a program.

libgcobol/ChangeLog:

	* Makefile.am: Move UDF-support to posix/shim, add install targets
	* Makefile.in: Regenerate
	* charmaps.cc (__gg__currency_signs): Use std::string.
	* charmaps.h: Include string and vector headers.
	(class charmap_t): Use std::string and vector for currency.
	* config.h.in: Regenerate.
	* configure: Regenerate.
	* configure.ac: Check for libxml2.
	* intrinsic.cc (numval_c): Constify.
	* libgcobol.cc (struct program_state): Use std::string and vector.
	(__gg__inspect_format_2): Add debug messages.
	* libgcobol.h (__gg__get_default_currency_string): Constify.
	* valconv.cc (expand_picture): Use std::string and vector.
	(__gg__string_to_numeric_edited): Use std::string and vector.
	(__gg__currency_sign_init): Use std::string and vector.
	(__gg__currency_sign): Use std::string and vector.
	* xmlparse.cc (xml_push_parse): Reformat.
	* posix/stat.cc: Removed.
	* posix/stat.h: Removed.
	* .gitignore: New file.
	* compat/README.md: New file.
	* compat/lib/gnu/CBL_ALLOC_MEM.cbl: New file.
	* compat/lib/gnu/CBL_CHECK_FILE_EXIST.cbl: New file.
	* compat/lib/gnu/CBL_DELETE_FILE.cbl: New file.
	* compat/lib/gnu/CBL_FREE_MEM.cbl: New file.
	* compat/t/Makefile: New file.
	* compat/t/smoke.cbl: New file.
	* posix/README.md: New file.
	* posix/bin/Makefile: New file for UDF-developer.
	* posix/bin/headers: New file.
	* posix/bin/scrape.awk: New file.
	* posix/bin/sizeofs.c: New file.
	* posix/bin/udf-gen: New file.
	* posix/cpy/posix-errno.cbl: New file.
	* posix/cpy/statbuf.cpy: New file.
	* posix/cpy/tm.cpy: New file.
	* posix/errno.cc: Removed.
	* posix/localtime.cc: Removed.
	* posix/shim/stat.cc: New file.
	* posix/shim/stat.h: New file.
	* posix/t/Makefile: New file.
	* posix/t/errno.cbl: New file.
	* posix/t/exit.cbl: New file.
	* posix/t/localtime.cbl: New file.
	* posix/t/stat.cbl: New file.
	* posix/tm.h: Removed.
	* posix/udf/posix-exit.cbl: New file.
	* posix/udf/posix-localtime.cbl: New file.
	* posix/udf/posix-mkdir.cbl: New file.
	* posix/udf/posix-stat.cbl: New file.
	* posix/udf/posix-unlink.cbl: New file.

Author: James K. Lowden

gcc/cobol/cdf.y

@@ -151,6 +151,9 @@ void input_file_status_notify();
   cdfval_t operator/( const cdfval_base_t& lhs, const cdfval_base_t& rhs );
   cdfval_t negate( cdfval_base_t lhs );
 
+  cbl_field_t
+  cdf_literalize( const std::string& name, const cdfval_t& value );
+
 }
 
 %{
@@ -353,6 +356,11 @@ cdf_define:	CDF_DEFINE cdf_constant NAME as cdf_expr[value] override
 		    }
 		    YYERROR;
 		  }
+                  if( symbols_begin() < symbols_end() ) {
+                    cbl_field_t field = cdf_literalize($NAME, $value);
+                    symbol_field_add(current_program_index(), &field);                    
+                  }
+
 		}
 	|	CDF_DEFINE cdf_constant NAME '=' cdf_expr[value] override
 		{  /* accept, but as error */
@@ -952,3 +960,5 @@ cdfval_base_t::operator()( const YDFLTYPE& loc ) {
   // cppcheck-suppress returnTempReference
   return verify_integer(loc, *this) ? *this : zero;
 }
+
+  

gcc/cobol/genapi.cc

@@ -5145,8 +5145,8 @@ parser_alphabet( const cbl_alphabet_t& alphabet )
 
     case custom_encoding_e:
       {
-#pragma message "Use program-id to disambiguate"
-      size_t alphabet_index = symbol_index(symbol_elem_of(&alphabet));
+#pragma message "Verify program-id is disambiguated"
+      size_t alphabet_index = symbol_unique_index(symbol_elem_of(&alphabet));
 
       unsigned char ach[256];
 
@@ -7166,7 +7166,6 @@ initialize_the_data()
           build_int_cst_type(INT, current_encoding(national_encoding_e)),
           NULL_TREE);
 
-  __gg__currency_signs = __gg__ct_currency_signs;
   // We initialize currency both at compile time and run time
   __gg__currency_sign_init();
   gg_call(VOID,
@@ -9911,8 +9910,8 @@ parser_file_add(struct cbl_file_t *file)
           __func__);
     }
 
-#pragma message "Use program-id to disambiguate"
-  size_t symbol_table_index = symbol_index(symbol_elem_of(file));
+#pragma message "Verify program-id is disambiguated"
+  size_t symbol_table_index = symbol_unique_index(symbol_elem_of(file));
 
   gg_call(VOID,
           "__gg__file_init",
@@ -14608,6 +14607,7 @@ void
 parser_exception_file( cbl_field_t *tgt, cbl_file_t *file)
   {
   Analyze();
+  RETURN_IF_PARSE_ONLY;
   gg_call(VOID,
           "__gg__func_exception_file",
           gg_get_address_of(tgt->var_decl_node),

gcc/cobol/parse.y

@@ -2397,7 +2397,7 @@ config_paragraph:
         |       SOURCE_COMPUTER  '.' NAME '.'
         |       SOURCE_COMPUTER  '.' NAME with_debug '.'
         |       OBJECT_COMPUTER  '.' 
-        |       OBJECT_COMPUTER  '.' NAME[computer] collations '.'
+        |       OBJECT_COMPUTER  '.' NAME[computer] object_computer '.'
         |       REPOSITORY dot
         |       REPOSITORY dot repo_members '.'
                 ;
@@ -2528,7 +2528,7 @@ with_debug:     with DEBUGGING MODE {
                 }
                 ;
 
-collations:     %empty
+object_computer: %empty
         |       char_classification
         |       collating_sequence
         |       char_classification collating_sequence
@@ -4842,13 +4842,15 @@ value_clause:   VALUE all LITERAL[lit] {
                   }
                   if( $value != NULLS ) {
                     auto fig = constant_of(constant_index($value));
-                    current_field()->data.initial = fig->data.initial;
+                    cbl_field_t *field = current_field();
+                    field->data.initial = fig->data.initial;
                   }
                 }
         |       /* VALUE is */ NULLPTR
                 {
                     auto fig = constant_of(constant_index(NULLS));
-                    current_field()->data.initial = fig->data.initial;
+                    cbl_field_t *field = current_field();
+                    field->data.initial = fig->data.initial;
                 }
         |       VALUE error
                 {
@@ -4938,10 +4940,13 @@ any_length:     ANY LENGTH
                   if( field->attr & any_length_e ) {
                     error_msg(@1, "ANY LENGTH already set");
                   }
+                  const char *prog_name = current.program()->name;
+                  bool is_compat = 0 < compat_programs.count(prog_name);
                   if( ! (field->level == 1 &&
                          current_data_section == linkage_datasect_e &&
                          (1 < current.program_level() ||
-			      current.program()->is_function())) ) {
+			      current.program()->is_function() ||
+                              is_compat)) ) {
                     error_msg(@1, "ANY LENGTH valid only for 01 "
                             "in LINKAGE SECTION of a function or contained program");
                     YYERROR;
@@ -10338,11 +10343,13 @@ go_to:          GOTO labels[args]
 resume:         RESUME NEXT STATEMENT
                 {
                   statement_begin(@1, RESUME);
+                  if( dialect_proscribed( @1, dialect_ibm_e, "RESUME") ) YYERROR;
                   parser_clear_exception();
                 }
         |       RESUME label_1[tgt]
                 {
                   statement_begin(@1, RESUME);
+                  if( dialect_proscribed( @1, dialect_ibm_e, "RESUME") ) YYERROR;
                   parser_clear_exception();
 		  $tgt->used = @1.first_line;
                   parser_goto( cbl_refer_t(), 1, &$tgt );
@@ -10708,11 +10715,10 @@ function_udf:   FUNCTION_UDF '(' arg_list[args] ')' {
 		  const auto returning = cbl_field_of(symbol_at(L->returning));
                   $$ = new_temporary_clone(returning);
 		  $$->data.initial = returning->name; // user's name for the field
-                  cbl_field_attr_t call_attr
-                                 = (cbl_field_attr_t)(quoted_e|hex_encoded_e);
-                  cbl_field_t *name = new_literal(strlen(L->name),
-                                                  L->name,
-                                                  call_attr);
+
+                  // Pretend hex-encoded because that means use verbatim.
+                  auto attr = cbl_field_attr_t(quoted_e | hex_encoded_e);
+                  auto name = new_literal(strlen(L->name), L->name, attr);
                   ast_call( @1, name, $$, narg, args, NULL, NULL, true );
                 }
                 ;
@@ -12083,6 +12089,7 @@ void ast_call( const YYLTYPE& loc, cbl_refer_t name, const cbl_refer_t& returnin
                            name.field->data, 77 };
     called.attr |= name.field->attr;
     snprintf(called.name, sizeof(called.name), "_%s", name.field->data.initial);
+    called.attr |= name.field->attr;
     name.field = cbl_field_of(symbol_field_add(PROGRAM, &called));
     symbol_field_location(field_index(name.field), loc);
     parser_symbol_add(name.field);

gcc/cobol/parse_ante.h

@@ -111,6 +111,15 @@ extern int yydebug;
 
 #include <cstdarg>
 
+// These programs in libgcobol/compat are allowed to use ANY LENGTH even though
+// they look like top-level programs.
+static const std::set<std::string> compat_programs {
+  "CBL_ALLOC_MEM", 
+  "CBL_CHECK_FILE_EXIST", 
+  "CBL_DELETE_FILE", 
+  "CBL_FREE_MEM", 
+};
+
 const char *
 consistent_encoding_check( const YYLTYPE& loc, const char input[] ) {
   cbl_field_t faux = {};
@@ -180,6 +189,15 @@ has_clause( int data_clauses, data_clause_t clause ) {
   return clause == (data_clauses & clause);
 }
 
+static bool
+dialect_proscribed( const YYLTYPE& loc, cbl_dialect_t dialect, const char msg[] ) {
+  if( dialect == cbl_dialects ) {
+    error_msg(loc, "dialect %s does not allow syntax: %qs",
+              cbl_dialect_str(dialect), msg);
+    return true;
+  }
+  return false;
+}
 
 static bool
 is_cobol_charset( const char name[] ) {
@@ -2521,9 +2539,9 @@ intrinsic_call_2( cbl_field_t *tgt, int token, const cbl_refer_t *r1, cbl_refer_
     error_msg(args[n].loc, "invalid parameter '%s'", args[n].field->name);
     return false;
   }
-  const char *fund = intrinsic_cname(token);
-  if( !fund ) return false;
-  parser_intrinsic_call_2( tgt, fund, args[0], args[1] );
+  const char *func = intrinsic_cname(token);
+  if( !func ) return false;
+  parser_intrinsic_call_2( tgt, func, args[0], args[1] );
   return true;
 }
 

gcc/cobol/scan.l

@@ -572,7 +572,7 @@ REVERSED	{ return REVERSED; }
 RETURN		{ return RETURN; }
 RESTRICTED	{ return RESTRICTED; }
 
-RESUME		{
+RESUME		{ // RESUME is ISO syntax, not IBM.  
 		  if( ! dialect_ibm() ) return RESUME;
 		  yylval.string = xstrdup(yytext);
 		  return typed_name(yytext);

gcc/cobol/symbols.cc

@@ -1862,6 +1862,7 @@ symbols_update( size_t first, bool parsed_ok ) {
                    __func__,
                    3 + cbl_field_type_str(field->type),
                    (fmt_size_t)isym, field->name, field->data.capacity);
+          gcc_unreachable();
         }
       }
       return 0;
@@ -2187,12 +2188,9 @@ symbol_field_parent_set( cbl_field_t *field )
           return NULL;
         }
         prior->type = FldGroup;
-        prior->codeset.set();
-////        if( ! prior->codeset.set() ) { // maybe just ignore?
-//// Dubner sez: Ignore.  This was triggering with -finternal-ebcdic
-////          ERROR_FIELD(prior, "%qs is already National", prior->name);
-////          return NULL;
-////        }
+        if( ! prior->codeset.set() ) { // needs attention
+          dbgmsg("'%s' is already National", prior->name);
+        }
         field->attr |= numeric_group_attrs(prior);
       }
       // verify level 88 domain value
@@ -2250,6 +2248,8 @@ add_token( symbol_elem_t sym ) {
   return sym;
 }
 
+const std::list<cbl_field_t> cdf_literalize();
+
 /*
  * When adding special registers, be sure to create the actual cblc_field_t
  * in libgcobol/constants.cc.
@@ -2455,6 +2455,14 @@ symbol_table_init(void) {
   table.nelem = p - table.elems;
   assert(table.nelem < table.capacity);
 
+  // Add any CDF values already defined as literals.
+  // After symbols are ready, the CDF adds them directly. 
+  const std::list<cbl_field_t> cdf_values = cdf_literalize();
+  table.nelem += cdf_values.size();
+  assert(table.nelem < table.capacity);
+  
+  p = std::transform(cdf_values.begin(), cdf_values.end(), p, elementize);
+  
   // Initialize symbol table.
   symbols = table;
 

gcc/cobol/symbols.h

@@ -57,6 +57,17 @@ enum cbl_dialect_t {
   dialect_gnu_e = 0x04,
 };
 
+static inline const char *
+cbl_dialect_str(cbl_dialect_t dialect)  {
+  switch(dialect) {
+  case dialect_gcc_e: return "gcc";
+  case dialect_ibm_e: return "ibm";
+  case dialect_mf_e:  return "mf";
+  case dialect_gnu_e: return "gnu";
+  }
+  return "???";
+};
+
 // Dialects may be combined. 
 extern unsigned int cbl_dialects;
 void cobol_dialect_set( cbl_dialect_t dialect );
@@ -143,11 +154,6 @@ const char * cbl_field_attr_str( cbl_field_attr_t attr );
 
 cbl_field_attr_t literal_attr( const char prefix[] );
 
-static inline bool
-is_working_storage(uint32_t attr) {
-  return 0 == (attr & (linkage_e | local_e));
-}
-
 int cbl_figconst_tok( const char *value );
 enum cbl_figconst_t cbl_figconst_of( const char *value );
 const char * cbl_figconst_str( cbl_figconst_t fig );
@@ -391,6 +397,26 @@ struct cbl_field_data_t {
     return valify();
   }
 
+  // If initial (of Numeric Edited) has any length but capacity, adjust it.  
+  bool manhandle_initial() {
+    assert(capacity > 0);
+    assert(initial != nullptr);
+    if( capacity < strlen(initial) ) {
+      char *p = const_cast<char*>(initial);
+      p[capacity] = '\0';
+      return true;
+    }
+    if( strlen(initial) < capacity ) {
+      auto tgt = reinterpret_cast<char *>( xmalloc(capacity + 1) );
+      auto pend = tgt + capacity;
+      auto p = std::copy(initial, initial + strlen(initial), tgt);
+      std::fill(p, pend, 0x20);
+      p = pend - 1;
+      *p = '\0';
+      initial = tgt;
+    }
+    return false;
+  }
   bool initial_within_capacity() const {
     return initial[capacity] == '\0'
       ||   initial[capacity] == '!';
@@ -630,7 +656,7 @@ struct cbl_field_t {
                uint32_t level = 0, const cbl_name_t name = "", int line = 0 )
     : offset(0), type(type), usage(FldInvalid), attr(attr)
     , parent(0), our_index(0), level(level)
-    , line(line), file(0), data(data)
+    , line(line), name(""), file(0), data(data)
     , var_decl_node(nullptr), data_decl_node(nullptr)
   {
     gcc_assert(strlen(name) < sizeof this->name);
@@ -1539,15 +1565,6 @@ struct cbl_section_t {
     }
     gcc_unreachable();
   }
-  uint32_t attr() const {
-    switch(type) {
-    case file_sect_e:
-    case working_sect_e: return 0;
-    case linkage_sect_e: return linkage_e;
-    case local_sect_e:   return local_e;
-    }
-    gcc_unreachable();
-  }
 };
 
 struct cbl_locale_t {
@@ -2273,6 +2290,8 @@ struct cbl_until_addresses_t {
 
 size_t symbol_index(); // nth after first program symbol
 size_t symbol_index( const symbol_elem_t *e );
+size_t symbol_unique_index( const struct symbol_elem_t *e );
+
 struct symbol_elem_t * symbol_at( size_t index );
 
 struct cbl_options_t {