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 3185002..aefdfab 100644 --- a/gcc/cobol/cbldiag.h +++ b/gcc/cobol/cbldiag.h
@@ -190,8 +190,10 @@ 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 3e2f3d4..d6ffac1 100644 --- a/gcc/cobol/cobol1.cc +++ b/gcc/cobol/cobol1.cc
@@ -577,6 +577,14 @@ // 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 bd11694..c1afc53 100644 --- 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 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 @@ 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 a7a3092..5b839a4 100644 --- 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 61b1f58..f50224f 100644 --- 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 @@ 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 6b33e91..e2518e1 100644 --- a/gcc/cobol/messages.cc +++ b/gcc/cobol/messages.cc
@@ -139,7 +139,11 @@ // 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 5739ff1..5f7e4ea 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y
@@ -789,13 +789,13 @@ %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 @@ 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 @@ {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 @@ | 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 @@ 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; } /*