diff --git a/gcc/cobol/UAT/testsuite.src/syn_definition.at b/gcc/cobol/UAT/testsuite.src/syn_definition.at
index dacf0eeb404d2213807ada6d58fbd638bd19b9a0..d04a897d01862a8d487b2a76dbab6100990ac678 100644
--- a/gcc/cobol/UAT/testsuite.src/syn_definition.at
+++ b/gcc/cobol/UAT/testsuite.src/syn_definition.at
@@ -807,10 +807,12 @@ AT_CHECK([$COMPILE_ONLY badprog.cob], [1], [],
[badprog.cob:8:24: error: F1: SAME AS uses its own parent MESSAGE-TEXT-2
8 | 02 F1 SAME AS MESSAGE-TEXT-2.
| ^
-badprog.cob:10:14: error: F1 created with SAME AS or TYPE TO, cannot have new member FILLER
+badprog.cob:9:23: error: F1 created with SAME AS or TYPE TO, cannot have new member FILLER
+ 9 | 01 MT2 SAME AS MESSAGE-TEXT-2.
+ | ^
+badprog.cob:10:14: error: 05 FILLER is not part of an 01 record
10 | 05 FILLER PIC 9999.
| ^
-badprog.cob:10:14: error: 05 FILLER is not part of an 01 record
badprog.cob:11:38: error: 01 MT3 SAME AS precludes other DATA DIVISION clauses
11 | 01 MT3 SAME AS MESSAGE-TEXT-2 PIC X.
| ^
diff --git a/gcc/cobol/UAT/testsuite.src/syn_file.at b/gcc/cobol/UAT/testsuite.src/syn_file.at
index 0f850cf8f5fc9c4ac1366b73bc7d20edc3e109b3..e9c90f31212089ba1cbfbb259a9fd7bcaf654de5 100644
--- a/gcc/cobol/UAT/testsuite.src/syn_file.at
+++ b/gcc/cobol/UAT/testsuite.src/syn_file.at
@@ -116,9 +116,12 @@ AT_DATA([prog.cob], [
])
AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
-[prog.cob:10: error: file name not found at 'file1'
-:16: error: line 7: file2 lacks a file description detected at end of file
-:16: 2 errors in DATA DIVISION, compilation ceases detected at end of file
+[prog.cob:10:8: error: file name not found
+ 10 | FD file1.
+ | ^
+prog.cob:15:21: error: line 7: file2 lacks a file description
+ 15 | STOP RUN.
+ | ^
cobol1: error: failed compiling prog.cob
])
AT_CLEANUP
@@ -147,7 +150,9 @@ AT_DATA([prog.cob], [
])
AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
-[prog.cob:9: error: file1 was defined previously on line 7
+[prog.cob:9:15: error: file1 was defined previously on line 7
+ 9 | SELECT file1 ASSIGN DISK.
+ | ^
cobol1: error: failed compiling prog.cob
])
AT_CLEANUP
@@ -176,8 +181,9 @@ AT_DATA([prog.cob], [
])
AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
-[prog.cob:13: error: line 7: file1 lacks a file description at 'PROCEDURE DIVISION'
-prog.cob:13: 1 errors in DATA DIVISION, compilation ceases at 'PROCEDURE DIVISION'
+[prog.cob:13:8: error: line 7: file1 lacks a file description
+ 13 | PROCEDURE DIVISION.
+ | ^
cobol1: error: failed compiling prog.cob
])
AT_CLEANUP
@@ -207,8 +213,9 @@ AT_DATA([prog.cob], [
])
AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
-[prog.cob:15: error: FD file1 previously defined on line 7 at 'file1'
-prog.cob:17: 1 errors in DATA DIVISION, compilation ceases at 'PROCEDURE DIVISION'
+[prog.cob:15:8: error: FD file1 previously defined on line 7
+ 15 | FD file1.
+ | ^
cobol1: error: failed compiling prog.cob
])
AT_CLEANUP
@@ -236,8 +243,9 @@ AT_DATA([prog.cob], [
])
AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
-[prog.cob:8: error: ASSIGN clause missing for TEST-FILE
-prog.cob:13: 1 errors in DATA DIVISION, compilation ceases at 'PROCEDURE DIVISION'
+[prog.cob:7:15: error: ASSIGN clause missing for TEST-FILE
+ 7 | SELECT TEST-FILE
+ | ^
cobol1: error: failed compiling prog.cob
])
@@ -274,8 +282,12 @@ AT_DATA([prog.cob], [
])
AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
-[prog.cob:20: error: START invalid with sequential file TEST-FILE at 'END-START'
-prog.cob:22: error: START invalid with sequential file TEST-FILE2 at 'END-START'
+[prog.cob:19:18: error: START invalid with sequential file TEST-FILE
+ 19 | START TEST-FILE KEY EQUAL TEST-REC
+ | ^
+prog.cob:21:18: error: START invalid with sequential file TEST-FILE2
+ 21 | START TEST-FILE2 KEY EQUAL TEST-REC2
+ | ^
cobol1: error: failed compiling prog.cob
])
@@ -333,16 +345,19 @@ AT_DATA([prog.cob], [
# FIXME: "is not defined" should be changed in "is not defined in file ..."
AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
-[prog.cob:41: error: line 12: TEST-P2 of TEST-SOME is not defined in file description at 'PROCEDURE DIVISION'
-prog.cob:41: error: line 12: TEST-P1 of TEST-SOME is not defined in file description at 'PROCEDURE DIVISION'
-prog.cob:41: error: line 12: TEST-P3 of TEST-SOME is not defined in file description at 'PROCEDURE DIVISION'
-prog.cob:41: error: line 19: NOT-THERE of TEST-FILE is not defined at 'PROCEDURE DIVISION'
-prog.cob:41: error: line 19: SOME-REC of TEST-FILE is not defined in file description at 'PROCEDURE DIVISION'
-prog.cob:41: error: line 19: NOT-THERE of TEST-FILE is not defined at 'PROCEDURE DIVISION'
-prog.cob:41: error: line 25: NOT-IN-FILE1 of TEST-MORE is not defined at 'PROCEDURE DIVISION'
-prog.cob:41: error: line 25: NOT-IN-FILE2 of TEST-MORE is not defined at 'PROCEDURE DIVISION'
-prog.cob:41: error: line 25: NOT-IN-FILE1 of TEST-MORE is not defined at 'PROCEDURE DIVISION'
-prog.cob:41: 9 errors in DATA DIVISION, compilation ceases at 'PROCEDURE DIVISION'
+[prog.cob:41:8: error: line 12: TEST-P2 of TEST-SOME is not defined in file description
+ 41 | PROCEDURE DIVISION.
+ | ^
+prog.cob:41:8: error: line 12: TEST-P1 of TEST-SOME is not defined in file description
+prog.cob:41:8: error: line 12: TEST-P3 of TEST-SOME is not defined in file description
+prog.cob:41:8: error: line 19: NOT-THERE of TEST-FILE is not defined
+ 41 | PROCEDURE DIVISION.
+ | ^
+prog.cob:41:8: error: line 19: SOME-REC of TEST-FILE is not defined in file description
+prog.cob:41:8: error: line 19: NOT-THERE of TEST-FILE is not defined
+prog.cob:41:8: error: line 25: NOT-IN-FILE1 of TEST-MORE is not defined
+prog.cob:41:8: error: line 25: NOT-IN-FILE2 of TEST-MORE is not defined
+prog.cob:41:8: error: line 25: NOT-IN-FILE1 of TEST-MORE is not defined
cobol1: error: failed compiling prog.cob
])
AT_CLEANUP
@@ -367,8 +382,9 @@ AT_DATA([prog.cob], [
# cobc says: prog.cob:11: error: syntax error, unexpected Identifier, expecting DYNAMIC or RANDOM or SEQUENTIAL
# but why?
AT_CHECK([$COMPILE_ONLY prog.cob], [1], [],
-[:13: error: line 12: testfile lacks a file description detected at end of file
-:13: 1 errors in DATA DIVISION, compilation ceases detected at end of file
+[prog.cob:12:31: error: line 12: testfile lacks a file description
+ 12 | STATUS IS stat.
+ | ^
cobol1: error: failed compiling prog.cob
])
AT_CLEANUP
diff --git a/gcc/cobol/cbldiag.h b/gcc/cobol/cbldiag.h
index b8663b3d18835d5ea1c8058874014dac5c73206a..2a4234a5e25e381b5a1c5db5b023a7f15f8dd412 100644
--- a/gcc/cobol/cbldiag.h
+++ b/gcc/cobol/cbldiag.h
@@ -41,7 +41,7 @@ bool yywarn( const char fmt[], ... );
struct YYLTYPE;
#endif
#ifndef YDFLTYPE
-struct YDFLTYPE;
+struct YDFLTYPE;
#endif
// an error at a location, called from the parser for semantic errors
void error_msg( const YYLTYPE& loc, const char gmsgid[], ... );
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index e12b7673ba2ec459d52abaa84466e9a62e38f342..25d8289836c695c86515b6bc733f1098cbb56630 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -608,13 +608,13 @@
struct cbl_ffi_arg_t *ffi_arg;
struct ffi_args_t *ffi_args;
- struct { cbl_refer_t *ffi_name, *ffi_returning;
+ struct { YYLTYPE loc; cbl_refer_t *ffi_name, *ffi_returning;
ffi_args_t *using_params; } ffi_impl;
struct { bool common, initial, recursive; } comminit;
struct { enum select_clause_t clause; cbl_file_t *file; } select_clause;
struct { size_t clauses; cbl_file_t *file; } select_clauses;
- struct { char *on, *off; } switches;
+ struct { YYLTYPE loc; char *on, *off; } switches;
struct cbl_domain_t *false_domain;
struct { size_t also; unsigned char *low, *high; } colseq;
struct { cbl_field_attr_t attr; int nbyte; } pic_part;
@@ -1239,7 +1239,7 @@ opt_init_value: BINARY ZERO { $$ = constant_index(NULLS); }
sprintf(ach, "%d", (int)($1.data[0]));
//auto f = new_literal($1.data);
auto f = new_literal(ach);
- f = field_add(f);
+ f = field_add(@1, f);
$$ = field_index(f);
}
| LOW_VALUES { $$ = constant_index(LOW_VALUES); }
@@ -1429,7 +1429,7 @@ select: SELECT optional NAME[name] select_clauses[clauses] '.'
}
// install file, and set record area's name
- if( (file = file_add(file)) == NULL ) YYERROR;
+ if( (file = file_add(@name, file)) == NULL ) YYERROR;
auto ifile = symbol_index(symbol_elem_of(file));
// update keys
for( auto p = file->keys;
@@ -1450,7 +1450,7 @@ select: SELECT optional NAME[name] select_clauses[clauses] '.'
file.line = yylineno;
if( !namcpy(file.name, $name) ) YYERROR;
- if( file_add(&file) == NULL ) YYERROR;
+ if( file_add(@name, &file) == NULL ) YYERROR;
}
;
selected_name: external scalar { $$ = $2; }
@@ -1467,7 +1467,7 @@ selected_name: external scalar { $$ = $2; }
0, 0, 0, nonarray, 0, "", 0, cbl_field_t::linkage_t(),
{len,len,0,0, $name.data, NULL, {NULL}, {NULL}}, NULL };
field.attr |= literal_attr($name.prefix);
- $$ = new cbl_refer_t( field_add(&field) );
+ $$ = new cbl_refer_t( field_add(@name, &field) );
}
;
external: %empty /* GnuCOBOL uses EXTERNAL to control name resolution. */
@@ -1927,7 +1927,8 @@ repo_program: PROGRAM_kw NAME repo_as
assert(program);
prog.data.initial = program->name;
}
- symbol_field_add(PROGRAM, &prog);
+ auto e = symbol_field_add(PROGRAM, &prog);
+ symbol_field_location(symbol_index(e), @NAME);
}
;
@@ -1980,7 +1981,7 @@ special_name: dev_mnemonic
field.data.domain = domain;
domains.clear();
- if( field_add(&field) == NULL ) {
+ if( field_add(@2, &field) == NULL ) {
dbgmsg("failed class");
YYERROR;
}
@@ -2216,7 +2217,7 @@ upsi: UPSI is NAME
{
assert($UPSI);
size_t parent = symbol_index(symbol_field(0,0,"UPSI-0"));
- cbl_field_t *field = field_alloc(FldSwitch, parent, $NAME);
+ cbl_field_t *field = field_alloc(@NAME, FldSwitch, parent, $NAME);
if( !field ) YYERROR;
field->attr = constant_e;
field->data.initial = $UPSI;
@@ -2225,7 +2226,7 @@ upsi: UPSI is NAME
{
assert($UPSI);
size_t parent = symbol_index(symbol_field(0,0,"UPSI-0"));
- cbl_field_t *field = field_alloc(FldSwitch, parent, $NAME);
+ cbl_field_t *field = field_alloc(@NAME, FldSwitch, parent, $NAME);
if( !field ) YYERROR;
field->attr = constant_e;
field->data.initial = $UPSI;
@@ -2234,12 +2235,12 @@ upsi: UPSI is NAME
const uint32_t bitn = $UPSI[0] - '0', value = (1 << bitn);
if( $entry.on ) {
- cbl_field_t *on = field_alloc(FldSwitch, parent, $entry.on);
+ cbl_field_t *on = field_alloc(@NAME, FldSwitch, parent, $entry.on);
if( !on ) YYERROR;
on->data.upsi_mask = new cbl_upsi_mask_t(true, value);
}
if( $entry.off ) {
- cbl_field_t *off = field_alloc(FldSwitch, parent, $entry.off);
+ cbl_field_t *off = field_alloc(@NAME, FldSwitch, parent, $entry.off);
if( !off ) YYERROR;
off->data.upsi_mask = new cbl_upsi_mask_t(false, value);
}
@@ -2251,12 +2252,12 @@ upsi: UPSI is NAME
const uint32_t bitn = $UPSI[0] - '0', value = (1 << bitn);
if( $entry.on ) {
- cbl_field_t *on = field_alloc(FldSwitch, parent, $entry.on);
+ cbl_field_t *on = field_alloc($entry.loc, FldSwitch, parent, $entry.on);
if( !on ) YYERROR;
on->data.upsi_mask = new cbl_upsi_mask_t(true, value);
}
if( $entry.off ) {
- cbl_field_t *off = field_alloc(FldSwitch, parent, $entry.off);
+ cbl_field_t *off = field_alloc($entry.loc, FldSwitch, parent, $entry.off);
if( !off ) YYERROR;
off->data.upsi_mask = new cbl_upsi_mask_t(false, value);
}
@@ -2264,22 +2265,26 @@ upsi: UPSI is NAME
;
upsi_entry: ON status is NAME
{
- $$.on = $NAME;
+ $$.loc = @NAME;
+ $$.on = $NAME;
$$.off = NULL;
}
| OFF status is NAME
{
- $$.on = NULL;
+ $$.loc = @NAME;
+ $$.on = NULL;
$$.off = $NAME;
}
| OFF status is NAME[off] ON status is NAME[on]
{
- $$.on = $on;
+ $$.loc = @off;
+ $$.on = $on;
$$.off = $off;
}
| ON status is NAME[on] OFF status is NAME[off]
{
- $$.on = $on;
+ $$.loc = @on;
+ $$.on = $on;
$$.off = $off;
}
;
@@ -2646,12 +2651,9 @@ depending: %empty
assert(e->type == SymField);
odo = symbol_index(e);
} else {
- struct cbl_field_t fwd = { 0,
- FldForward, FldInvalid, 0,0,0,0, nonarray, 0, "",
- 0, cbl_field_t::linkage_t(),
- {0,0,0,0, " ", NULL, {NULL}, {NULL}}, NULL };
- if( !namcpy(fwd.name, $3) ) YYERROR;
- odo = field_index(field_add(&fwd));
+ e = symbol_field_forward_add(PROGRAM, 0, $NAME, yylineno);
+ if( !e ) YYERROR;
+ odo = field_index(cbl_field_of(e));
}
file->record_length = odo;
@@ -2843,7 +2845,7 @@ index_field1: ctx_name[name]
YYERROR;
}
- auto index = field_add(&field);
+ auto index = field_add(@name, &field);
if( !index ) {
YYERROR;
}
@@ -2871,7 +2873,7 @@ level_name: LEVEL ctx_name
{ 0,0,0,0, NULL, NULL, { NULL }, { NULL } }, NULL };
if( !namcpy(field.name, $2) ) YYERROR;
- $$ = field_add(&field);
+ $$ = field_add(@2, &field);
if( !$$ ) {
YYERROR;
}
@@ -2894,7 +2896,7 @@ level_name: LEVEL ctx_name
nonarray, yylineno, "",
0, {}, { 0,0,0,0, NULL, NULL, { NULL }, { NULL } }, NULL };
- $$ = field_add(&field);
+ $$ = field_add(@1, &field);
if( !$$ ) {
YYERROR;
}
@@ -3027,7 +3029,7 @@ data_descr1: level_name
yywarn("%s was defined by CDF", field.name);
}
}
- if( ($$ = field_add(&field)) == NULL ) {
+ if( ($$ = field_add(@name, &field)) == NULL ) {
error_msg(@name, "failed level 78");
YYERROR;
}
@@ -3048,7 +3050,7 @@ data_descr1: level_name
field.data.domain = domain;
- if( ($$ = field_add(&field)) == NULL ) {
+ if( ($$ = field_add(@2, &field)) == NULL ) {
error_msg(@NAME, "failed level 88");
YYERROR;
}
@@ -3076,7 +3078,7 @@ data_descr1: level_name
field.data.false_value = $domains;
domains.clear();
- if( ($$ = field_add(&field)) == NULL ) {
+ if( ($$ = field_add(@2, &field)) == NULL ) {
error_msg(@NAME, "failed level 88");
YYERROR;
}
@@ -3112,6 +3114,7 @@ data_descr1: level_name
}
symbol_elem_t *orig = symbol_at(field_index($orig));
$$ = cbl_field_of(symbol_field_alias(orig, $alias));
+ symbol_field_location(field_index($$), @alias);
}
| name66[alias] RENAMES name[orig] THRU name[thru]
@@ -3174,6 +3177,7 @@ data_descr1: level_name
symbol_elem_t *orig = symbol_at(field_index($orig));
symbol_elem_t *last = symbol_at(field_index($thru));
$$ = cbl_field_of(symbol_field_alias2(orig, last, $alias));
+ symbol_field_location(field_index($$), @alias);
}
| level_name[field] data_clauses
@@ -4127,7 +4131,8 @@ same_clause: SAME AS name
YYERROR;
}
- symbol_field_same_as( field, other );
+ auto e = symbol_field_same_as( field, other );
+ symbol_field_location( symbol_index(e), @name );
}
;
@@ -4175,7 +4180,8 @@ type_clause: TYPE to typename
{
cbl_field_t *field = current_field();
if( $typename ) {
- symbol_field_same_as(field, $typename);
+ auto e = symbol_field_same_as(field, $typename);
+ symbol_field_location( symbol_index(e), @typename );
}
}
| USAGE is typename
@@ -4186,7 +4192,8 @@ type_clause: TYPE to typename
}
cbl_field_t *field = current_field();
if( $typename ) {
- symbol_field_same_as(field, $typename);
+ auto e = symbol_field_same_as(field, $typename);
+ symbol_field_location( symbol_index(e), @typename );
}
}
;
@@ -5984,7 +5991,7 @@ name: qname
$$ = cbl_field_of(e);
}
}
- assert($$);
+ gcc_assert($$);
}
;
@@ -7750,7 +7757,7 @@ end_start: %empty %prec START
start_body: filename[file]
{
statement_begin(@$, START);
- file_start_args.init($file);
+ file_start_args.init(@file, $file);
parser_file_start( $file, lt_op, 0 );
}
| filename[file] KEY relop name[key]
@@ -7764,26 +7771,26 @@ start_body: filename[file]
yywarn("START: key #%d '%s' has size %d",
key, $key->name, size);
}
- file_start_args.init($file);
+ file_start_args.init(@file, $file);
parser_file_start( $file, relop_of($relop), key, ksize );
}
| filename[file] KEY relop name[key] with LENGTH expr
{ // lexer swallows IS, although relop allows it.
statement_begin(@$, START);
int key = $file->key_one($key);
- file_start_args.init($file);
+ file_start_args.init(@file, $file);
parser_file_start( $file, relop_of($relop), key, *$expr );
}
| filename[file] FIRST
{
statement_begin(@$, START);
- file_start_args.init($file);
+ file_start_args.init(@file, $file);
parser_file_start( $file, lt_op, -1 );
}
| filename[file] LAST
{
statement_begin(@$, START);
- file_start_args.init($file);
+ file_start_args.init(@file, $file);
parser_file_start( $file, gt_op, -2 );
}
;
@@ -8869,7 +8876,7 @@ call_impl: CALL call_body[body]
if( narg > 0 ) {
pargs = use_list(params, args);
}
- parser_call( *$body.ffi_name,
+ ast_call( $body.loc, *$body.ffi_name,
*$body.ffi_returning, narg, pargs, NULL, NULL, false );
current.declaratives_evaluate();
}
@@ -8883,7 +8890,7 @@ call_cond: CALL call_body[body] call_excepts[except]
if( narg > 0 ) {
pargs = use_list(params, args);
}
- parser_call( *$body.ffi_name,
+ ast_call( $body.loc, *$body.ffi_name,
*$body.ffi_returning, narg, pargs,
$except.on_error, $except.not_error, false );
auto handled = ec_type_t( static_cast<size_t>(ec_program_e) |
@@ -9522,7 +9529,7 @@ function_udf: FUNCTION_UDF '(' arg_list[args] ')' {
return actual;
} );
auto name = new_literal(strlen(L->name), L->name, quoted_e);
- parser_call( name, $$, narg, args, NULL, NULL, true );
+ ast_call( @1, name, $$, narg, args, NULL, NULL, true );
}
| FUNCTION_UDF_0 {
static const size_t narg = 0;
@@ -9532,7 +9539,7 @@ function_udf: FUNCTION_UDF '(' arg_list[args] ')' {
$$ = new_temporary_clone(cbl_field_of(symbol_at(L->returning)));
auto name = new_literal(strlen(L->name), L->name, quoted_e);
- parser_call( name, $$, narg, args, NULL, NULL, true );
+ ast_call( @1, name, $$, narg, args, NULL, NULL, true );
}
;
@@ -10647,8 +10654,7 @@ cdf_none: ENTER
%%
-#undef parser_call
-void parser_call2( cbl_refer_t name, cbl_refer_t returning,
+void ast_call( const YYLTYPE& loc, cbl_refer_t name, cbl_refer_t returning,
size_t narg, cbl_ffi_arg_t args[],
cbl_label_t *except,
cbl_label_t *not_except,
@@ -10662,14 +10668,15 @@ void parser_call2( cbl_refer_t name, cbl_refer_t returning,
snprintf(called.name, sizeof(called.name), "_%s", name.field->data.initial);
called.data = name.field->data;
name.field = cbl_field_of(symbol_field_add(PROGRAM, &called));
+ symbol_field_location(field_index(name.field), loc);
parser_symbol_add(name.field);
}
- if( getenv("parser_call2") && yydebug ) {
- yywarn("%s: calling %s returning %s with %zu args:", __func__,
- name_of(name.field),
- (returning.field)? returning.field->name : "[none]",
- narg);
+ if( getenv("ast_call") ) {
+ dbgmsg("%s: calling %s returning %s with %zu args:", __func__,
+ name_of(name.field),
+ (returning.field)? returning.field->name : "[none]",
+ narg);
for( size_t i=0; i < narg; i++ ) {
const char *crv = "?";
switch(args[i].crv) {
@@ -10678,8 +10685,8 @@ void parser_call2( cbl_refer_t name, cbl_refer_t returning,
case by_content_e: crv = "con"; break;
case by_value_e: crv = "val"; break;
}
- yywarn("%s: %4zu: %s @%p %s", __func__,
- i, crv, args[i].refer.field, args[i].refer.field->name);
+ dbgmsg("%s: %4zu: %s @%p %s", __func__,
+ i, crv, args[i].refer.field, args[i].refer.field->name);
}
}
parser_call( name, returning, narg, args, except, not_except, is_function );
diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h
index b27ab8750912cc55e580f0bdaae38782ccfe9349..7391a9c324a67bf0e2dfa2b82da952b373432110 100644
--- a/gcc/cobol/parse_ante.h
+++ b/gcc/cobol/parse_ante.h
@@ -224,10 +224,9 @@ intrinsic_inconsistent_parameter( size_t n, cbl_refer_t *args );
static inline bool
namcpy( cbl_name_t tgt, const char *src ) {
// snprintf(3): writes at most size bytes (including the terminating NUL byte)
- snprintf(tgt, sizeof(cbl_name_t), "%s", src);
- if( sizeof(cbl_name_t) - 1 < strlen(src) ) {
- yyerror("name truncated to '%s' (max %zu characters)",
- tgt, sizeof(cbl_name_t)-1);
+ if( -1 == snprintf(tgt, sizeof(cbl_name_t), "%s", src) ) {
+ dbgmsg("logic error: name truncated to '%s' (max %zu characters)",
+ tgt, sizeof(cbl_name_t)-1);
return false;
}
return true;
@@ -469,15 +468,15 @@ static class file_start_args_t {
cbl_file_t *file;
public:
file_start_args_t() : file(NULL) {}
- void init( cbl_file_t *file ) {
+ void init( YYLTYPE loc, cbl_file_t *file ) {
this->file = file;
if( is_sequential(file) ) {
- yyerror("START invalid with sequential file %s", file->name);
+ error_msg(loc, "START invalid with sequential file %s", file->name);
}
}
bool ready() const { return file != NULL; }
void call_parser_file_start() {
- //// not needed: parser_file_start(file, sequentially);
+ // not needed: parser_file_start(file, sequentially);
file = NULL;
}
} file_start_args;
@@ -2799,7 +2798,7 @@ field_of( const char F[], int L, const char name[] ) {
#define field_of( F ) field_of(__func__, __LINE__, (F))
static struct cbl_field_t *
-field_add( cbl_field_t *field ) {
+field_add( const YYLTYPE& loc, cbl_field_t *field ) {
switch(current_data_section) {
case not_data_datasect_e:
case file_datasect_e:
@@ -2815,7 +2814,7 @@ field_add( cbl_field_t *field ) {
struct symbol_elem_t *e = symbol_field_add(PROGRAM, field);
if( !e ) return NULL;
-
+ symbol_field_location(symbol_index(e), loc);
field = cbl_field_of(e);
assert(field->type != FldDisplay);
@@ -2968,11 +2967,11 @@ value_encoding_check( cbl_field_t *field ) {
#pragma GCC diagnostic ignored "-Wmissing-field-initializers"
static struct cbl_field_t *
-field_alloc( cbl_field_type_t type, size_t parent, const char name[] ) {
+field_alloc( const YYLTYPE& loc, cbl_field_type_t type, size_t parent, const char name[] ) {
cbl_field_t *f, field = { .type = type, .usage = FldInvalid,
.parent = parent, .line = yylineno };
if( !namcpy(field.name, name) ) return NULL;
- f = field_add(&field);
+ f = field_add(loc, &field);
assert(f);
return f;
}
@@ -2988,22 +2987,19 @@ cbl_file_t protofile = { .org = file_disorganized_e,
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wformat-truncation"
static cbl_file_t *
-file_add( cbl_file_t *file = NULL ) {
- struct cbl_file_t proto = protofile;
- proto.org = file_sequential_e;
- if( !file ) file = &proto;
-
+file_add( YYLTYPE loc, cbl_file_t *file ) {
+ gcc_assert(file);
struct cbl_field_t area = { .type = FldAlphanumeric,
.level = 1,
.line = yylineno,
.data = { .capacity = 0 } },
- *field = field_add(&area);
+ *field = field_add(loc, &area);
file->default_record = field_index(field);
// install file, and set record area's name
auto e = symbol_file_add(PROGRAM, file);
if( !e ) {
- yyerror("%s was defined previously on line %d", file->name, file->line);
+ error_msg(loc, "%s was defined previously on line %d", file->name, file->line);
return NULL;
}
file = cbl_file_of(e);
@@ -3030,10 +3026,12 @@ alphabet_add( cbl_encoding_t encoding ) {
return cbl_alphabet_of(e);
}
+// The current field always exists in the symbol tablek, even if it's incomplete.
static cbl_field_t *
current_field(cbl_field_t * field = NULL) {
static cbl_field_t *local;
if( field ) local = field;
+ gcc_assert(field_index(local));
return local;
}
@@ -3477,15 +3475,13 @@ file_section_parent_set( cbl_field_t *field ) {
return file_section_fd > 0;
}
-void parser_call2( cbl_refer_t name, cbl_refer_t returning,
+void ast_call(const YYLTYPE& loc, cbl_refer_t name,
+ cbl_refer_t returning,
size_t narg, cbl_ffi_arg_t args[],
cbl_label_t *except,
cbl_label_t *not_except,
bool is_function );
-#define parser_call( name, returning, narg, args, except, not_except, is_function ) \
- parser_call2(name, returning, narg, args, except, not_except, is_function )
-
cbl_field_t *
ast_file_status_between( file_status_t lower, file_status_t upper );
@@ -3558,3 +3554,5 @@ static void ast_first_statement( int first_line ) {
parser_first_statement(first_line);
}
}
+
+
diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc
index 8ae36fa99ef25a8acb49f7c2165b337af4e49a62..a9b456a990081a6075d2312ab0342327ee01958f 100644
--- a/gcc/cobol/symbols.cc
+++ b/gcc/cobol/symbols.cc
@@ -58,6 +58,20 @@ public:
}
};
+static std::map<size_t, YYLTYPE> field_locs;
+
+void
+symbol_field_location( size_t ifield, const YYLTYPE& loc ) {
+ gcc_assert(field_at(ifield));
+ field_locs[ifield] = loc;
+}
+YYLTYPE
+symbol_field_location( size_t ifield ) {
+ auto p = field_locs.find(ifield);
+ gcc_assert(p != field_locs.end());
+ return p->second;
+}
+
static struct symbol_table_t {
int fd;
size_t capacity, nelem;
@@ -213,6 +227,13 @@ cbl_ffi_arg_t( cbl_ffi_crv_t crv,
if( refer && refer != refer->empty() ) delete refer;
}
+#define ERROR_FIELD(F, ...) \
+ do{ \
+ auto loc = symbol_field_location(field_index(F)); \
+ error_msg(loc, __VA_ARGS__); \
+ } while(0)
+
+
cbl_field_t *
symbol_valid_udf_args( size_t function, std::list<cbl_refer_t> args ) {
auto L = cbl_label_of(symbol_at(function));
@@ -232,15 +253,16 @@ symbol_valid_udf_args( size_t function, std::list<cbl_refer_t> args ) {
size_t iarg(1);
e++; // skip over linkage_sect_e, which appears after the function
if( e->type != SymField ) {
- yyerror("FUNCTION %s has no defined parameter matching arg %zu, '%s'",
- L->name, iarg, arg.field->name );
+ ERROR_FIELD(arg.field,
+ "FUNCTION %s has no defined parameter matching arg %zu, '%s'",
+ L->name, iarg, arg.field->name );
return NULL;
}
auto tgt = cbl_field_of(e);
if( ! valid_move(tgt, arg.field) ) {
- yyerror("FUNCTION %s arg %zu, '%s' cannot be passed to %s, type %s",
+ ERROR_FIELD(tgt, "FUNCTION %s arg %zu, '%s' cannot be passed to %s, type %s",
L->name, iarg, arg.field->pretty_name(),
tgt->pretty_name(), 3 + cbl_field_type_str(tgt->type) );
return NULL;
@@ -1245,7 +1267,7 @@ grow_redefined_group( cbl_field_t *redefined, const cbl_field_t *field ) {
*/
if( 1 < redefined->level ) {
if( field_memsize(redefined) < field_memsize(field) ) {
- yyerror("line %d: %s (size %u) larger than REDEFINES %s (size %u)",
+ ERROR_FIELD(field, "line %d: %s (size %u) larger than REDEFINES %s (size %u)",
field->line,
field->name, field_memsize(field),
redefined->name, field_memsize(redefined));
@@ -1881,7 +1903,7 @@ symbols_update( size_t first, bool parsed_ok ) {
if( odo != 0 ) {
auto odo_field = cbl_field_of(symbol_at(odo)); // get not-FldForward if exists
if( is_forward(odo_field) ) {
- yyerror("table %s (line %d) DEPENDS ON %s, which is not defined",
+ ERROR_FIELD(field, "table %s (line %d) DEPENDS ON %s, which is not defined",
field->name, field->line, odo_field->name);
} else {
// set odo to found field
@@ -1922,7 +1944,7 @@ symbols_update( size_t first, bool parsed_ok ) {
// Better to report an error than to fail mysteriously with "0 errors".
if( yydebug || parse_error_count() == 0 ) {
if( field->type == FldInvalid ) {
- yyerror("line %d: %s %s requires PICTURE",
+ ERROR_FIELD(field, "line %d: %s %s requires PICTURE",
field->line, field->level_str(), field->name);
} else {
@@ -1971,14 +1993,14 @@ symbols_update( size_t first, bool parsed_ok ) {
// Verify REDEFINing field has no ODO components
auto parent = symbol_redefines(field);
if( parent && !is_record_area(parent) && is_variable_length(field) ) {
- yyerror("line %d: REDEFINES field %s cannot be variable length",
+ ERROR_FIELD(field, "line %d: REDEFINES field %s cannot be variable length",
field->line, field->name);
return 0;
}
if( field->type == FldInvalid ) {
dbgmsg("%s:%d: %s", __func__, __LINE__, field_str(field));
- yyerror("line %d: %s %s requires PICTURE",
+ ERROR_FIELD(field, "line %d: %s %s requires PICTURE",
field->line, field->level_str(), field->name);
continue;
}
@@ -2218,17 +2240,14 @@ symbol_field_parent_set( struct cbl_field_t *field )
if( prior->level < field->level ) {
if( prior->has_attr(same_as_e) ) {
- yyerror("%s created with SAME AS or TYPE TO, cannot have new member %s",
+ ERROR_FIELD(prior, "%s created with SAME AS or TYPE TO, cannot have new member %s",
prior->name, field->name);
return NULL;
}
field->parent = e - symbols.elems;
if( 1 < field->level && field->level < 50 ) {
if( had_picture(prior) ) {
- auto efile = symbol_in_file(e);
- const char *filename = efile? efile->elem.filename : NULL;
- yyerrorvl(prior->line, filename,
- "error: group %s cannot have PICTURE clause", prior->name);
+ ERROR_FIELD(prior, "group %s cannot have PICTURE clause", prior->name);
return NULL;
}
prior->type = FldGroup;
@@ -2256,7 +2275,7 @@ symbol_field_parent_set( struct cbl_field_t *field )
return false;
} );
if( ! all_numeric ) {
- yyerror("%s %s invalid VALUE for numeric type %s",
+ ERROR_FIELD(field, "%s %s invalid VALUE for numeric type %s",
field->level_str(), field->name, prior->name);
}
}
@@ -2562,7 +2581,7 @@ symbol_typedef_add( size_t program, struct cbl_field_t *field ) {
assert(field->is_typedef());
if( field->is_strongdef() && field->level != 1 ) {
- yyerror("%s %s STRONG TYPEDEF must be level 01",
+ ERROR_FIELD(field, "%s %s STRONG TYPEDEF must be level 01",
field->level_str(), field->name);
return NULL;
}
@@ -2736,7 +2755,6 @@ symbol_field_add( size_t program, struct cbl_field_t *field )
}
update_symbol_map2( e );
-
return e;
}
@@ -2993,16 +3011,15 @@ seek_parent( const symbol_elem_t *e, size_t level ) {
* "The condition-name entries for a particular conditional variable
* shall immediately follow the entry describing the item...."
*/
-
struct symbol_elem_t *
symbol_field_same_as( cbl_field_t *tgt, const cbl_field_t *src ) {
if( target_in_src(tgt, src) ) {
- yyerror("%s %s may not reference itself as part of %s %s",
+ ERROR_FIELD(tgt, "%s %s may not reference itself as part of %s %s",
tgt->level_str(), tgt->name, src->level_str(), src->name);
return NULL;
}
if( tgt->level == 77 && src->type == FldGroup ) {
- yyerror("%s %s TYPE TO %s must be an elementary item",
+ ERROR_FIELD(tgt, "%s %s TYPE TO %s must be an elementary item",
tgt->level_str(), tgt->name, src->name);
return NULL;
}
@@ -3424,7 +3441,7 @@ new_literal_add( const char initial[], uint32_t len, enum cbl_field_attr_t attr
if( ! field->internalize() )
{
- yyerror("inconsistent string literal encoding for '%s'", initial);
+ ERROR_FIELD(field, "inconsistent string literal encoding for '%s'", initial);
}
}
@@ -3720,7 +3737,7 @@ cbl_field_t::internalize() {
if( 0 < inbytesleft ) {
// data.capacity + inbytesleft is not correct if the remaining portion has
// multibyte characters. But the fact reamins that the VALUE is too big.
- yyerror("%s %s VALUE '%s' requires %zu bytes for size %u",
+ ERROR_FIELD(this, "%s %s VALUE '%s' requires %zu bytes for size %u",
cbl_field_t::level_str(level), name, data.initial,
data.capacity + inbytesleft, data.capacity );
}
@@ -4761,7 +4778,7 @@ cbl_file_key_t::deforward( size_t ifile ) {
auto parent = symbol_record_file(field);
if( ifield == fwd ) {
- yyerror("line %d: %s of %s "
+ ERROR_FIELD(field, "line %d: %s of %s "
"is not defined",
file->line, field->name, file->name);
return ifield;
@@ -4770,21 +4787,21 @@ cbl_file_key_t::deforward( size_t ifile ) {
// relative files have numeric keys that are not part of the record
if( file->org == file_relative_e ) {
if( parent != NULL ) {
- yyerror("line %d: RELATIVE file %s key %s "
+ ERROR_FIELD(field, "line %d: RELATIVE file %s key %s "
"is defined in file description",
file->line, file->name, field->name);
return ifield;
}
if( field->occurs.ntimes() ) {
- yyerror("line %d: RELATIVE file %s key %s "
+ ERROR_FIELD(field, "line %d: RELATIVE file %s key %s "
"cannot have OCCURS clause",
file->line, file->name, field->name);
return ifield;
}
if( ! (is_numeric(field) && 0 == field->data.rdigits) ) {
- yyerror("line %d: RELATIVE file %s key %s "
- "must be integer type",
- file->line, file->name, field->name);
+ ERROR_FIELD(field, "line %d: RELATIVE file %s key %s "
+ "must be integer type",
+ file->line, file->name, field->name);
return ifield;
}
return ifield;
@@ -4792,7 +4809,7 @@ cbl_file_key_t::deforward( size_t ifile ) {
// looked-up field must have same file as parent
if( ! (parent != NULL &&
symbol_index(symbol_elem_of(parent)) == ifile) ) {
- yyerror("line %d: %s of %s "
+ ERROR_FIELD(field, "line %d: %s of %s "
"is not defined in file description",
file->line, field->name, file->name);
}
@@ -4826,7 +4843,7 @@ cbl_file_t::deforward() {
auto field = cbl_field_of(symbol_at(user_status));
if( is_forward(field) ) {
- yyerror("%s of %s never defined in FD record",
+ ERROR_FIELD(field, "%s of %s never defined in FD record",
field->name, this->name);
}
}
@@ -4848,7 +4865,6 @@ cbl_file_t::keys_str() const {
return n + strlen(s);
} );
char *output = static_cast<char*>( xcalloc(1, n) ), *p = output;
- assert(output);
const char *sep = "";
*p++ = '[';
diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h
index 997fc16db8d7cb19ed94a1219252fae62b994995..8e227af1a3aef720991895aabce59a89b7a4e7f4 100644
--- a/gcc/cobol/symbols.h
+++ b/gcc/cobol/symbols.h
@@ -2066,6 +2066,9 @@ struct symbol_elem_t * symbol_file_add( size_t program,
struct symbol_elem_t * symbol_section_add( size_t program,
struct cbl_section_t *section );
+void symbol_field_location( size_t ifield, const YYLTYPE& loc );
+YYLTYPE symbol_field_location( size_t ifield );
+
bool symbol_label_section_exists( size_t program );
size_t symbol_field_capacity( const cbl_field_t *field );
diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc
index 4f8f2f9db1e518cae991b6e1c37d4ce9b996fe57..695c3e18c0a8074fe7e1ed033ea29f30870ca4fd 100644
--- a/gcc/cobol/util.cc
+++ b/gcc/cobol/util.cc
@@ -2484,10 +2484,6 @@ dialect_error( const char term[], const char dialect[] ) {
term, dialect);
}
-/* This is the analog to warn(3) from "err .h". The formatted message is sent
- to stderr, the message from xstrerror() is appended, and processing
- continues */
-
bool fisdigit(int c)
{
return ISDIGIT(c);