cobol: Accept ASSIGN TO DEVICE.

For SELECT fd-name ASSIGN TO dev, "dev" may name either a runtime
environment variable (as previously) or, as now, an
implementation-defined device.  New warnings govern dialect
variations.  Fixes RT 3617.

gcc/cobol/ChangeLog:

	* cbldiag.h (enum cbl_diag_id_t): New warnings.
	* cobol1.cc (cobol_langhook_handle_option): Process warnings.
	* gcobol.1: Document warnings and devices.
	* lang-specs.h: Accept warngings.
	* lang.opt: Define warnings.
	* messages.cc: Associate warnings with dialects.
	* parse.y: Parse new syntax.

diff --git a/gcc/cobol/cbldiag.h b/gcc/cobol/cbldiag.h
index 3185002b7e8de503980bcc7f9f421d5526569e40..aefdfaba394bedbf3e3b371241177c69c436f227 100644 (file)
--- a/gcc/cobol/cbldiag.h
+++ b/gcc/cobol/cbldiag.h
@@ -190,8 +190,10 @@ enum cbl_diag_id_t : uint64_t {
   IbmVolatileE,  
   IbmVolatileW,  // dialect warning for ignored syntax
 
+  IsoAssignFile,
   IsoResume,
 
+  MfAssignExternal,
   MfBinaryLongLong,
   MfCallGiving,
   MfCallLiteral,

diff --git a/gcc/cobol/cobol1.cc b/gcc/cobol/cobol1.cc
index 3e2f3d43994e2204f95c9ea2d876b22f336a26b8..d6ffac128b7bc170ace2d81a43b9a3d16125e205 100644 (file)
--- a/gcc/cobol/cobol1.cc
+++ b/gcc/cobol/cobol1.cc
@@ -577,6 +577,14 @@ cobol_langhook_handle_option (size_t scode,
 
         // Warnings and errors
 
+        case OPT_Wassign_external:
+          cobol_warning(MfAssignExternal, assign_external, warning_as_error);
+          return true;
+
+        case OPT_Wassign_file:
+          cobol_warning(IsoAssignFile, assign_file, warning_as_error);
+          return true;
+
         case OPT_Wbinary_long_long:
           cobol_warning(MfBinaryLongLong, binary_long_long, warning_as_error);
           return true;

diff --git a/gcc/cobol/gcobol.1 b/gcc/cobol/gcobol.1
index bd11694ffd55f57fce0c83b12eaf3eedfe2babe2..c1afc53841afd94a7af1b045698f09435cbe3432 100644 (file)
--- a/gcc/cobol/gcobol.1
+++ b/gcc/cobol/gcobol.1
@@ -43,6 +43,8 @@
 .Op Fl Wno-high-order-bit
 .Op Fl Wno-bad-line-directive
 .Op Fl Wno-bad-numeric
+.Op Fl Wno-assign-external
+.Op Fl Wassign-file
 .Op Fl Wno-binary-long-long
 .Op Fl Wno-call-fd
 .Op Fl Wno-call-giving
@@ -602,6 +604,10 @@ Warn if APPLY COMMIT is used.
 Warn if malformed
 .Ql #line
 directive is encountered.
+.It Fl Wno-assign-external
+Warn if EXTERNAL is used with ASSIGN.
+.It Fl Wassign-file
+Warn if filename is used with ASSIGN.
 .It Fl Wno-binary-long-long
 Warn if BINARY-LONG-LONG is used.
 .It Fl Wno-call_fd
@@ -1283,6 +1289,48 @@ aliases.
 All computation \(em both integer and floating point \(em is done
 using 128-bit intermediate forms.
 .
+.Ss Devices
+.Nm
+implements these devices for the
+.Ql "SELECT ... ASSIGN TO"
+clause:
+.Bl -tag -width "standard output"
+.It Sy standard input
+STDIN
+SYSIN
+SYSIPT
+.It Sy standard output
+CONSOLE
+STDOUT
+SYSLIST
+SYSLST
+SYSOUT
+.It Sy standard error
+STDERR
+SYSPCH
+SYSPUNCH
+.It Sy /dev/null
+AFP_5A
+C01
+C02
+C03
+C04
+C05
+C06
+C07
+C08
+C09
+C10
+C11
+C12
+CSP
+S01
+S02
+S03
+S04
+S05
+.El
+.
 .Ss Environment Names
 In
 .Nm

diff --git a/gcc/cobol/lang-specs.h b/gcc/cobol/lang-specs.h
index a7a3092f0494b76b5c50aca42c4141789b7b9507..5b839a49a1491239e01b92a37ad9d036e085c1a9 100644 (file)
--- a/gcc/cobol/lang-specs.h
+++ b/gcc/cobol/lang-specs.h
@@ -53,6 +53,8 @@
        "%{Wno-high-order-bit} "
        "%{Wno-bad-line-directive} "
        "%{Wno-bad-numeric} "
+       "%{Wassign-external} "
+       "%{Wassign-file} "
        "%{Wno-binary-long-long} "
        "%{Wno-call-fd} "
        "%{Wno-call-giving} "

diff --git a/gcc/cobol/lang.opt b/gcc/cobol/lang.opt
index 61b1f583c83a9ba0c0850adc6cf16f62d716075d..f50224fac05a18919102f2f24b556719b5d7f848 100644 (file)
--- a/gcc/cobol/lang.opt
+++ b/gcc/cobol/lang.opt
@@ -1,3 +1,4 @@
+
 ; lang.opt -- Options for the gcc Cobol front end.
 
 ; Copyright (C) 2021-2026 Free Software Foundation, Inc.
@@ -103,6 +104,16 @@ Wlevel-78-defined
 Cobol Warning Var(level_78_defined, 1) Init(1)
 Warn if CDF defines Level 78 constant.
 
+; IbmAssignFile
+Wassign-file
+Cobol Warning Var(assign_file, 1) Init(1)
+Warn if filename is used with ASSIGN.
+
+; MfAssignExternal
+Wassign-external
+Cobol Warning Var(assign_external, 1) Init(1)
+Warn if EXTERNAL is used with ASSIGN.
+
 ; MfBinaryLongLong
 Wbinary-long-long
 Cobol Warning Var(binary_long_long, 1) Init(1)

diff --git a/gcc/cobol/messages.cc b/gcc/cobol/messages.cc
index 6b33e91fc3423629b8c05dfaac333da7230e0ea2..e2518e112403cd930aa1151b137b08e86756acdc 100644 (file)
--- a/gcc/cobol/messages.cc
+++ b/gcc/cobol/messages.cc
@@ -139,7 +139,11 @@ std::set<cbl_diag_t> cbl_diagnostics {
 
   // RESUME not supported by IBM
   { IsoResume, "-Wcobol-resume", diagnostics::kind::error, dialect_ibm_e },
+  // IBM, MF, and GNU all support ASSIGN TO filename, so we keep mum. 
+  { IsoAssignFile, "-Wassign-file", diagnostics::kind::ignored, dialect_ibm_mf_gnu },
+  
 
+  { MfAssignExternal, "-Wassign-external", diagnostics::kind::error, dialect_mf_gnu },
   { MfBinaryLongLong, "-Wbinary-long-long", diagnostics::kind::error, dialect_mf_gnu },
   { MfCallGiving, "-Wcall-giving", diagnostics::kind::error, dialect_mf_gnu },
   { MfCallLiteral, "-Wcall-literal", diagnostics::kind::error, dialect_mf_e },

diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index 5739ff14e65a23badc34967f62c53a79024e639b..5f7e4ea7a228813fcf6e945ba0fef9dfd8333469 100644 (file)
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -789,13 +789,13 @@ class locale_tgt_t {
 %type   <min_max>       record_vary rec_contains from_to record_desc
 %type   <file_op>       read_file rewrite1 write_file
 %type   <field>         data_descr data_descr1 write_what file_record
-%type   <field>         name88
+%type   <field>         name88 selected_name 
 %type   <refer>         advancing  advance_by
 %type   <refer>         alphaval alpha_val numeref scalar scalar88 scalar_any
 %type   <refer>         tableref tableish
 %type   <refer>         varg varg1 varg1a start_after start_pos
 %type   <refer>         expr expr_term compute_expr free_tgt by_value_arg
-%type   <refer>         move_tgt selected_name read_key read_into vary_by
+%type   <refer>         move_tgt read_key read_into vary_by
 %type   <refer>         num_operand envar search_expr any_arg
 %type   <accept_func>  accept_body
 %type   <refers>        subscript_exprs subscripts arg_list free_tgts 
@@ -2161,7 +2161,12 @@ select:         SELECT optional NAME[name] select_clauses[clauses] '.'
                   if( file_add(@name, &file) == NULL ) YYERROR;
                 }
                 ;
-selected_name:  external scalar { $$ = $2; }
+selected_name:  external NAME {
+                  enum { parent = 0 };
+                  auto e = symbol_field_forward_add(PROGRAM, parent,
+                                                    $NAME, @NAME.first_line);
+                  $$ = cbl_field_of(e); // might become a data item
+                }
         |       external LITERAL[name]
                 {
                   const char *name = string_of($name);
@@ -2176,11 +2181,13 @@ selected_name:  external scalar { $$ = $2; }
                                      {len,len,0,0, $name.data} };
                   field.attr |= literal_attr($name.prefix);
                   field.codeset.set();
-                  $$ = new cbl_refer_t( field_add(@name, &field) );
+                  $$ = field_add(@name, &field);
                 }
                 ;
 external:       %empty /* GnuCOBOL uses EXTERNAL to control name resolution.  */
-        |       EXTERNAL
+        |       EXTERNAL {
+                  dialect_ok(@1, MfAssignExternal, "EXTERNAL");
+                }
                 ;
 
 select_clauses: select_clause { $$.clauses = $1.clause; $$.file = $1.file; }
@@ -2364,21 +2371,52 @@ unique_key:     %empty          { $$ = true; }
         |       with DUPLICATES { $$ = false; }
                 ;
 
+                /*
+                 * IBM:  SELECT fd-name ASSIGN to filename
+                 * ISO:  SELECT fd-name ASSIGN to device USING data-item 
+                 * both: SELECT fd-name ASSIGN to literal
+                 * 
+                 * For ISO, device is implementation-defined. We use
+                 * cbl_special_name_t, and whatever file is defined for it. The
+                 * interpretation of data-item is likewise implemetation
+                 * defined.  If both device and data-item are present, it seems
+                 * logical to assign the device to the file described by the
+                 * value of data-item.
+                 * 
+                 * For IBM, we interpret filename as a potential runtime
+                 * environment variable. If libgcobol finds filename as an
+                 * environment variable, the value of that variable is used as
+                 * the filename, else filename itself is used verbatim.
+                 * 
+                 * If the argument to ASSIGN to is a literal, that exact name
+                 * will be opened.  ASSIGN to literal cannot be used with USING.
+                 */
 assign_clause:  ASSIGN to selected_name[selected]  {
                   $$.clause = assign_clause_e;
                   $$.file = new cbl_file_t(protofile);
-                  $$.file->filename = field_index($selected->field);
+                  $$.file->filename = field_index($selected);  // of the FldLiteralA
+                  if( ! is_quoted($selected) ) {
+                    dialect_ok(@selected, IsoAssignFile, $selected->name);
+                  }
                 }
         |       ASSIGN to device_name[dev] USING name {
                   $$.clause = assign_clause_e;
                   $$.file = new cbl_file_t(protofile);
-                  $$.file->assign($dev.id);
+                  $$.file->device = $dev.id;
                   $$.file->filename = field_index($name);
+                  cbl_unimplemented_at(@$, "ISO ASSIGN TO %s USING", "...");
                 }
-        |       ASSIGN to device_name[dev] {
+        |       ASSIGN to device_name[dev] { // ISO syntax
                   $$.clause = assign_clause_e;
                   $$.file = new cbl_file_t(protofile);
-                  $$.file->assign($dev.id);
+                  auto special = symbol_special($dev.id);
+                  uint32_t len = strlen(special->os_filename);
+                  cbl_field_t field { FldLiteralA,
+                                      hex_encoded_e | quoted_e | constant_e,
+                                     {len,len,0,0, special->os_filename} };
+                  field.codeset.set();
+                  auto f = field_add(@dev, &field);
+                  $$.file->filename = field_index(f);
                   if( $$.file->org == file_disorganized_e ) {
                     $$.file->org = file_sequential_e;
                   } 
@@ -7431,7 +7469,7 @@ name:           qname
                   if( ($$ = field_find(@1, names)) == NULL ) {
                     if( procedure_div_e == current_division  ) {
                       error_msg(inner.loc,
-                                "DATA-ITEM '%s' not found", inner.name );
+                                "DATA-ITEM %qs not found", inner.name );
                       YYERROR;
                     }
                     /*