From e3ad636877c586983aaf46a14884cb66727f54b7 Mon Sep 17 00:00:00 2001
From: "James K. Lowden" <jklowden@symas.com>
Date: Sat, 13 Apr 2024 16:12:10 -0400
Subject: [PATCH] add TYPE TO errors
---
gcc/cobol/UAT/failsuite.src/typedef.at | 13 ++--
gcc/cobol/parse.y | 92 ++++++++++++++++++++------
gcc/cobol/parse_ante.h | 2 +-
gcc/cobol/scan.l | 24 ++++---
gcc/cobol/symbols.cc | 22 +++++-
gcc/cobol/symbols.h | 2 +
6 files changed, 117 insertions(+), 38 deletions(-)
diff --git a/gcc/cobol/UAT/failsuite.src/typedef.at b/gcc/cobol/UAT/failsuite.src/typedef.at
index 1340e560d400..7bf6a29234a4 100644
--- a/gcc/cobol/UAT/failsuite.src/typedef.at
+++ b/gcc/cobol/UAT/failsuite.src/typedef.at
@@ -211,11 +211,14 @@ AT_DATA([badprog.cob], [
])
-AT_CHECK([$COMPILE_ONLY badprog.cob], [1], [],
-[badprog.cob:8: error: item may not reference itself
-badprog.cob:10: error: entry following TYPE TO may not be subordinate to it
-badprog.cob:11: error: illegal combination of TYPE TO with other clauses
-badprog.cob:12: error: elementary item expected
+AT_CHECK([$COMPILE_ONLY -dialect mf badprog.cob], [1], [],
+[badprog.cob:8: error: 02 F1 may not reference itself as part of 01 MESSAGE-TEXT-2T at 'MESSAGE-TEXT-2T'
+badprog.cob:10: error: F1 created with SAME AS or TYPE TO, cannot have new member FILLER at 'FILLER'
+badprog.cob:10: error: 05 FILLER on is not part of an 01 record at 'FILLER'
+badprog.cob:12: error: PIC incompatible with TYPE TO
+badprog.cob:12: error: 77 OUTPUT-NAME TYPE TO MESSAGE-TEXT-2T must be an elementary item at 'MESSAGE-TEXT-2T'
+.:13: 5 errors in DATA DIVISION, compilation ceases detected at end of file
+cobol1: error: failed compiling badprog.cob
])
AT_CLEANUP
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index 0a941575ff94..ded53436448d 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -3203,25 +3203,27 @@ data_clauses: data_clause
}
}
| data_clauses data_clause {
+ const char *clause = "data";
+ switch($2) {
+ case occurs_clause_e: clause = "OCCURS"; break;
+ case picture_clause_e: clause = "PIC"; break;
+ case usage_clause_e: clause = "USAGE"; break;
+ case value_clause_e: clause = "VALUE"; break;
+ case global_clause_e: clause = "GLOBAL"; break;
+ case external_clause_e: clause = "EXTERNAL"; break;
+ case justified_clause_e: clause = "JUSTIFIED"; break;
+ case redefines_clause_e: clause = "REDEFINES"; break;
+ case blank_zero_clause_e: clause = "BLANK WHEN ZERO"; break;
+ case synched_clause_e: clause = "SYNCHRONIZED"; break;
+ case sign_clause_e: clause = "SIGN"; break;
+ case based_clause_e: clause = "BASED"; break;
+ case same_clause_e: clause = "SAME AS"; break;
+ case volatile_clause_e: clause = "VOLATILE"; break;
+ case type_clause_e: clause = "TYPE"; break;
+ case typedef_clause_e: clause = "TYPEDEF"; break;
+ }
if( ($$ & $2) == $2 ) {
- const char *msg = "data";
- switch($2) {
- case occurs_clause_e: msg = "OCCURS"; break;
- case picture_clause_e: msg = "PIC"; break;
- case usage_clause_e: msg = "USAGE"; break;
- case value_clause_e: msg = "VALUE"; break;
- case global_clause_e: msg = "GLOBAL"; break;
- case external_clause_e: msg = "EXTERNAL"; break;
- case justified_clause_e: msg = "JUSTIFIED"; break;
- case redefines_clause_e: msg = "REDEFINES"; break;
- case blank_zero_clause_e: msg = "BLANK WHEN ZERO"; break;
- case synched_clause_e: msg = "SYNCHRONIZED"; break;
- case sign_clause_e: msg = "SIGN"; break;
- case based_clause_e: msg = "BASED"; break;
- case same_clause_e: msg = "SAME AS"; break;
- case volatile_clause_e: msg = "VOLATILE"; break;
- }
- yyerrorv("%s clause repeated", msg);
+ yyerrorv("%s clause repeated", clause);
YYERROR;
}
@@ -3239,6 +3241,24 @@ data_clauses: data_clause
$$ |= $2;
+ // If any implied TYPE bits are on in addition to
+ // type_clause_e, they're in conflict.
+ static const size_t type_implies =
+ // ALIGNED clause not implemented
+ blank_zero_clause_e | justified_clause_e | picture_clause_e
+ | sign_clause_e | synched_clause_e | usage_clause_e;
+
+ if( type_clause_e < ($$ & (type_clause_e | type_implies)) ) {
+ if( $2 == type_clause_e ) {
+ yyerror("error: TYPE TO incompatible with ALIGNED, "
+ "BLANK WHEN ZERO, JUSTIFIED, PICTURE, SIGN, "
+ "SYNCHRONIZED, and USAGE");
+ } else {
+ yyerrorv("error: %s incompatible with TYPE TO", clause);
+ }
+ YYERROR;
+ }
+
if( ($$ & same_clause_e) == same_clause_e ) {
if( 0 < ($$ & ~same_clause_e) ) {
yyerrorv("error: %02u %s SAME AS "
@@ -7011,9 +7031,41 @@ set_tgts: set_tgt {
;
set_operand: set_tgt
| signed_literal { $$ = new_reference($1); }
- | ADDRESS of PROGRAM_kw namestr
+ | ADDRESS of FUNCTION ctx_name[name]
+ {
+ $$ = NULL;
+ auto e = symbol_function(0, $name);
+ if( e ) {
+ $$ = new cbl_refer_t(cbl_label_of(e));
+ } else {
+ e = symbol_find($name);
+ if( !e ) {
+ yyerrorv("error: %s not found", $name);
+ YYERROR;
+ }
+ $$ = new cbl_refer_t(cbl_field_of(e));
+ }
+ assert($$);
+ }
+ | ADDRESS of PROGRAM_kw ctx_name[name]
+ {
+ $$ = NULL;
+ auto label = symbol_program(0, $name);
+ if( label ) {
+ $$ = new cbl_refer_t(label);
+ } else {
+ auto e = symbol_find($name);
+ if( !e ) {
+ yyerrorv("error: %s not found", $name);
+ YYERROR;
+ }
+ $$ = new cbl_refer_t(cbl_field_of(e));
+ }
+ assert($$);
+ }
+ | ADDRESS of PROGRAM_kw LITERAL[lit]
{
- auto label = symbol_program(0, $namestr.data);
+ auto label = symbol_program(0, $lit.data);
$$ = new cbl_refer_t( label );
}
;
diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h
index c063508d7cc6..3253d86ca53f 100644
--- a/gcc/cobol/parse_ante.h
+++ b/gcc/cobol/parse_ante.h
@@ -200,7 +200,7 @@ enum data_clause_t {
based_clause_e = 0x0800,
same_clause_e = 0x1000,
volatile_clause_e = 0x2000,
- type_clause_e = usage_clause_e,
+ type_clause_e = 0x4000,
typedef_clause_e = 0x8000,
};
diff --git a/gcc/cobol/scan.l b/gcc/cobol/scan.l
index 79eba81bf19a..10cb2654caa4 100644
--- a/gcc/cobol/scan.l
+++ b/gcc/cobol/scan.l
@@ -164,7 +164,7 @@ NL [[:blank:]]*\r?\n[[:blank:]]*
PUSH_FILE \f?[#]FILE{SPC}PUSH{SPC}.+\f
POP_FILE \f?[#]FILE{SPC}POP\f
-%x procedure_div ident_state function classify when_not
+%x procedure_div ident_state addr_of function classify when_not
%x program_id_state comment_entries
%x author_state date_state field_level field_state dot_state
%x numeric_state name_state
@@ -1491,7 +1491,6 @@ USE({SPC}FOR)? { return USE; }
COMMAND-LINE { return COMMAND_LINE; }
COMMAND-LINE-COUNT { return COMMAND_LINE_COUNT; }
CONTENT { return CONTENT; }
- CONTENT { return CONTENT; }
DELIMITED { return DELIMITED; }
DELIMITER { return DELIMITER; }
ENVIRONMENT { return ENVIRONMENT; }
@@ -1516,12 +1515,13 @@ USE({SPC}FOR)? { return USE; }
return MIGHT_BE;
}
- {SORT_MERGE}{SPC}/(\f#)?{NAME} {
- yy_push_state(sort_state); return SORT; }
+ {SORT_MERGE}{SPC}(\f#)?/{NAME} { yy_push_state(sort_state); return SORT; }
+
+ ADDRESS{SPC}(OF{SPC})?/FUNCTION { yy_push_state(addr_of); return ADDRESS; }
FUNCTION { yy_push_state(function); return FUNCTION; }
- {NAME}/{OSPC}{DOTSEP} {
+ {NAME}/{OSPC}{DOTSEP} {
int token = keyword_tok(yytext);
if( token ) return token;
@@ -1537,18 +1537,20 @@ USE({SPC}FOR)? { return USE; }
return typed_name(yytext);
}
}
+
+<addr_of>FUNCTION { pop_return FUNCTION; }
+
+<when_not>NOT { yylval.number = NOT; pop_return MIGHT_BE; }
+
<classify>{
{ISNT}/{SPC}{NAMTYP} { yy_pop_state(); }
IS/{SPC}{NAMTYP} { yy_pop_state(); }
}
-<when_not>{
- NOT { yy_pop_state(); yylval.number = NOT; return MIGHT_BE; }
-}
<sort_state>{
- {NAME} { yylval.string = strdup(yytext);
- pop_return symbol_file(PROGRAM, yytext)? FILENAME : NAME;
- }
+ {NAME} { yylval.string = strdup(yytext);
+ pop_return symbol_file(PROGRAM, yytext)? FILENAME : NAME;
+ }
}
<datetime_fmt>{
diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc
index a2cd7eb97082..57bfe9296cad 100644
--- a/gcc/cobol/symbols.cc
+++ b/gcc/cobol/symbols.cc
@@ -1990,7 +1990,7 @@ symbol_field_parent_set( struct cbl_field_t *field )
cbl_field_t *parent = cbl_field_of(e);
if( parent->level < field->level ) {
if( parent->has_attr(same_as_e) ) {
- yyerrorv("error: %s created with SAME AS, cannot have new member %s",
+ yyerrorv("error: %s created with SAME AS or TYPE TO, cannot have new member %s",
parent->name, field->name);
return NULL;
}
@@ -2611,6 +2611,16 @@ symbol_field_alias2( struct symbol_elem_t *e, struct symbol_elem_t *e2,
return e;
}
+static const cbl_field_t *
+symbol_field_top_level( const cbl_field_t *field ) {
+ while( field->parent > 0 ) {
+ auto e = symbol_at(field->parent);
+ if( e->type != SymField ) break;
+ field = cbl_field_of(e);
+ }
+ return field;
+}
+
class elem_group_t {
const symbol_elem_t *bog, *eog;
public:
@@ -2632,6 +2642,16 @@ public:
struct symbol_elem_t *
symbol_field_same_as( cbl_field_t *tgt, const cbl_field_t *src ) {
+ if( symbol_field_top_level(tgt) == symbol_field_top_level(src) ) {
+ yyerrorv("error: %02d %s may not reference itself as part of %02d %s",
+ tgt->level, tgt->name, src->level, src->name);
+ return NULL;
+ }
+ if( tgt->level == 77 && src->type == FldGroup ) {
+ yyerrorv("error: %02d %s TYPE TO %s must be an elementary item",
+ tgt->level, tgt->name, src->name);
+ return NULL;
+ }
auto last_elem = symbol_at(field_index(tgt));
tgt->same_as(*src, src->is_typedef());
diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h
index 293e66f74897..0005e0f6b3f0 100644
--- a/gcc/cobol/symbols.h
+++ b/gcc/cobol/symbols.h
@@ -570,8 +570,10 @@ struct cbl_field_t {
type = that.type;
attr |= (that.attr & external_e);
attr |= same_as_e;
+
occurs = that.occurs; // might be partly wrong
data = that.data;
+
if( ! (is_typedef || that.type == FldClass) ) {
data.initial = NULL;
data.value = 0.0;
--
GitLab