diff --git a/gcc/cobol/UAT/Makefile b/gcc/cobol/UAT/Makefile
index 6c8da16d87845a00a7fa641e616100806554bc4d..aa1aff10298df8416a15649b04fabd50f3fd1e1b 100644
--- a/gcc/cobol/UAT/Makefile
+++ b/gcc/cobol/UAT/Makefile
@@ -25,11 +25,16 @@ FAILSUITE_AT_FILES=$(wildcard ./failsuite.src/*.at)
SKIPSUITE_AT_FILES=$(wildcard ./skipsuite.src/*.at)
BUGSUITE_AT_FILES=$(wildcard ./bugsuite.src/*.at)
+vis:
+ echo FAILURE.bad: $(FAILURE.bad)
+ echo FAILSUITE_OK_FILES: $(FAILSUITE_OK_FILES)
+
testsuite: atlocal $(TESTSUITE_AT_FILES) testsuite.at
autom4te --language=autotest -I $@.src -o $@ $@.at
-failsuite: atlocal $(FAILSUITE_AT_FILES) failsuite.at
- autom4te --language=autotest -I $@.src -o $@ $@.at
+failsuite: atlocal $(FAILSUITE_OK_FILES) failsuite.at
+ autom4te --language=autotest -I $@.src -o $@ \
+ $@.at $(addprefix failsuite.src/,typedef.at)
skipsuite: atlocal $(SKIPSUITE_AT_FILES) skipsuite.at
autom4te --language=autotest -I $@.src -o $@ $@.at
diff --git a/gcc/cobol/UAT/failsuite.src/typedef.at b/gcc/cobol/UAT/failsuite.src/typedef.at
index 9e5ae500b387255c294239ffb4efe54d958a36d8..7a5908973b257f8f1e5d748008d3d5f9cf1dfa5f 100644
--- a/gcc/cobol/UAT/failsuite.src/typedef.at
+++ b/gcc/cobol/UAT/failsuite.src/typedef.at
@@ -3,57 +3,60 @@ AT_COPYRIGHT([Test cases Copyright (C) 2024 Free Software Foundation
Written by Simon Sobisch])
-AT_KEYWORDS([fundamental EXTERNAL])
+AT_BANNER([TYPEDEF Tests])
-AT_DATA([caller.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. caller.
+AT_SETUP([typedef 1])
+AT_KEYWORDS([typedef])
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 INT IS TYPEDEF BINARY-LONG.
- 88 INT-ZERO VALUE 0.
- 88 INT-ONE VALUE 1.
- 77 EXT-INT IS TYPEDEF BINARY-LONG EXTERNAL.
- 77 INT-VAL IS TYPEDEF BINARY-LONG VALUE 12.
- 01 SOMEVAR USAGE INT VALUE 10.
- 01 SOMEVAR2 USAGE INT VALUE 11.
- 77 SOMEVAL USAGE INT-VAL.
- 77 SOMEEXT USAGE EXT-INT.
-
- PROCEDURE DIVISION.
- IF SOMEVAR <> 10
- DISPLAY "SOMEVAR (INT) wrong: " SOMEVAR.
- IF SOMEVAL <> 12
- DISPLAY "SOMEVAL (INT-VAL) wrong: " SOMEVAL.
- SET INT-ZERO OF SOMEVAR TO TRUE
- SET INT-ONE OF SOMEVAR2 TO TRUE
- IF SOMEVAR <> 0
- DISPLAY "SOMEVAR (INT) by SET wrong: " SOMEVAR.
- IF SOMEVAR2 <> 1
- DISPLAY "SOMEVAR2 (INT) by SET wrong: " SOMEVAR2.
- IF INT-ONE OF SOMEVAR
- OR NOT INT-ONE OF SOMEVAR2
- DISPLAY "CHECK BY condition-nam wrong".
- MOVE 42 TO SOMEEXT
- CALL "callee"
- GOBACK.
+AT_DATA([caller.cob], [
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. caller.
+
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 INT IS TYPEDEF BINARY-LONG.
+ 88 INT-ZERO VALUE 0.
+ 88 INT-ONE VALUE 1.
+ 77 EXT-INT IS TYPEDEF BINARY-LONG EXTERNAL.
+ 77 INT-VAL IS TYPEDEF BINARY-LONG VALUE 12.
+ 01 SOMEVAR USAGE INT VALUE 10.
+ 01 SOMEVAR2 USAGE INT VALUE 11.
+ 77 SOMEVAL USAGE INT-VAL.
+ 77 SOMEEXT USAGE EXT-INT.
+
+ PROCEDURE DIVISION.
+ IF SOMEVAR <> 10
+ DISPLAY "SOMEVAR (INT) wrong: " SOMEVAR.
+ IF SOMEVAL <> 12
+ DISPLAY "SOMEVAL (INT-VAL) wrong: " SOMEVAL.
+ SET INT-ZERO OF SOMEVAR TO TRUE
+ SET INT-ONE OF SOMEVAR2 TO TRUE
+ IF SOMEVAR <> 0
+ DISPLAY "SOMEVAR (INT) by SET wrong: " SOMEVAR.
+ IF SOMEVAR2 <> 1
+ DISPLAY "SOMEVAR2 (INT) by SET wrong: " SOMEVAR2.
+ IF INT-ONE OF SOMEVAR
+ OR NOT INT-ONE OF SOMEVAR2
+ DISPLAY "CHECK BY condition-nam wrong".
+ MOVE 42 TO SOMEEXT
+ CALL "callee"
+ GOBACK.
])
AT_DATA([callee.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. callee.
-
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 77 EXT-INT IS TYPEDEF BINARY-LONG EXTERNAL.
- 77 SOMEEXT USAGE EXT-INT.
-
- PROCEDURE DIVISION.
- IF SOMEEXT <> 42
- DISPLAY "SOMEEXT (EXT-INT) wrong: " SOMEEXT
- END-IF
- .
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. callee.
+
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 77 EXT-INT IS TYPEDEF BINARY-LONG EXTERNAL.
+ 77 SOMEEXT USAGE EXT-INT.
+
+ PROCEDURE DIVISION.
+ IF SOMEEXT <> 42
+ DISPLAY "SOMEEXT (EXT-INT) wrong: " SOMEEXT
+ END-IF
+ .
])
AT_CHECK([$COMPILE caller.cob], [0], [], [])
@@ -187,9 +190,11 @@ AT_DATA([progstd.cob], [
])
AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], [])
+AT_CLEANUP
+AT_SETUP([typedef 1])
-
+AT_KEYWORDS([typedef])
AT_DATA([badprog.cob], [
IDENTIFICATION DIVISION.
@@ -212,7 +217,7 @@ 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_CLEANUP
AT_SETUP([SAME AS clause])
AT_KEYWORDS([definition EXTERNAL GLOBAL])
@@ -276,6 +281,10 @@ AT_CLEANUP
# totally fine. This is directly copied from the standard (only added
# the syntactic parts missing).
+AT_SETUP([typedef 1])
+
+AT_KEYWORDS([typedef])
+
AT_DATA([prog.cob], [
IDENTIFICATION DIVISION.
PROGRAM-ID. prog.
@@ -407,3 +416,6 @@ AT_DATA([prog.cob], [
VALIDATE MY-MIXED-GROUP
GOBACK.
+])
+
+AT_CLEANUP
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index a1c50628116c0831bd34ace1f66d19a9d21ee441..71fdca596d93e5432ba7f4ec9162910deca85115 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -7455,7 +7455,7 @@ parser_perform_inline_times(struct cbl_perform_tgt_t *tgt,
}
void
-parser_set_conditional( struct cbl_refer_t refer, bool which_way )
+parser_set_conditional88( struct cbl_refer_t refer, bool which_way )
{
struct cbl_field_t *tgt = refer.field;
SHOW_PARSE
diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h
index 69113aab2693d962ebb7010b86802bcac6a3d83c..c66b367cc399929a08161a3fafda4f7ef6a65fbd 100644
--- a/gcc/cobol/genapi.h
+++ b/gcc/cobol/genapi.h
@@ -311,7 +311,7 @@ void
parser_alter( cbl_perform_tgt_t *tgt );
void
-parser_set_conditional( struct cbl_refer_t tgt, bool which_way );
+parser_set_conditional88( struct cbl_refer_t tgt, bool which_way );
void
parser_set_numeric(struct cbl_field_t *tgt, ssize_t value);
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index 783f01343fc8e713635c00cf9f9013ee9c84bc81..8c82640471b64d20616b7c1500cb619de987f4a0 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -3874,12 +3874,26 @@ type_clause: TYPE to typename
}
yywarn("warning: TYPE TO is provisional");
}
+ | USAGE is typename
+ {
+ if( ! dialect_mf() ) {
+ yyerror("error: USAGE TYPENAME requires -dialect mf");
+ YYERROR;
+ }
+ cbl_field_t *field = current_field();
+ if( $typename ) {
+ symbol_field_same_as(field, $typename);
+ }
+ yywarn("warning: USAGE TYPENAME is provisional");
+ }
;
typedef_clause: is TYPEDEF strong
{
cbl_field_t *field = current_field();
- if( field->level != 1 ) {
+ switch( field->level ) {
+ case 1: case 77: break;
+ default:
yyerrorv("error: %02d %s IS TYPEDEF must be level 01",
field->level, field->name);
}
@@ -7112,7 +7126,7 @@ set: SET set_tgts[tgts] TO set_operand[src]
refer.field->name);
return;
}
- parser_set_conditional(refer, tf);
+ parser_set_conditional88(refer, tf);
}
};
std::for_each($names->refers.begin(), $names->refers.end(),
diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h
index 83c1b31337d918e24f299c314a0d5aa67365b05e..70eacc18dbe31cc9bda04549c8a80f23cb37a07d 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 = 0x4000,
+ type_clause_e = usage_clause_e,
typedef_clause_e = 0x8000,
};
@@ -2843,6 +2843,11 @@ procedure_division_ready( cbl_field_t *returning, ffi_args_t *ffi_args ) {
if( symbol_redefines(f) ) continue;
if( f->has_attr(linkage_e) ) continue;
if( f->has_attr(local_e) ) continue;
+ if( f->is_typedef() ) {
+ auto isym = end_of_group( symbol_index(e) );
+ e = symbol_at(--isym);
+ continue;
+ }
static const bool like_parser_symbol_add = true;
parser_initialize(f, like_parser_symbol_add);
}
diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc
index 2e57410eef7bbbad24c1ab792a594a61a7878f82..6d03c15682298acc609a53f167f24af772ad4ecf 100644
--- a/gcc/cobol/symbols.cc
+++ b/gcc/cobol/symbols.cc
@@ -1504,6 +1504,7 @@ field_str( const cbl_field_t *field ) {
char parredef =
parent_of(field) != NULL && parent_of(field)->level == field->level? 'r' : 'P';
if( 'r' == parredef && field->level == 0 ) parredef = 'p';
+ if( field->has_attr(typedef_e) ) parredef = 'T';
const char *data = field->data.initial? field->data.initial : NULL;
if( data ) {
@@ -2622,10 +2623,26 @@ symbol_field_same_as( cbl_field_t *tgt, const cbl_field_t *src ) {
auto last_elem = symbol_at(field_index(tgt));
tgt->same_as(*src);
- if( tgt->type == FldGroup ) {
- size_t isrc = field_index(src);
- symbol_elem_t *bog = symbol_at(isrc);
- symbol_elem_t *eog = symbol_at_impl(end_of_group(isrc), true);
+ size_t isrc = field_index(src);
+
+ symbol_elem_t *bog = symbol_at(isrc);
+ symbol_elem_t *eog = symbol_at_impl(end_of_group(isrc), true);
+
+ if( src->type != FldGroup ) {
+ // For scalar, check for Level 88. Find next field with other parent.
+ eog = std::find_if( bog + 1,
+ symbols_end(),
+ [parent = isrc]( const auto& elem ) {
+ if( elem.type == SymField ) {
+ auto f = cbl_field_of(&elem);
+ assert(parent != f->parent || f->level == 88);
+ return parent != f->parent;
+ }
+ return true;
+ } );
+ }
+
+ if( bog + 1 < eog ) {
cbl_field_t dup = { .parent = field_index(tgt), .line = tgt->line };
// for each duplicate, map src index to duplicate index
@@ -3064,6 +3081,7 @@ temporaries_t::acquire( cbl_field_type_t type ) {
field = new_temporary_add(type);
} else {
auto p = fields.begin();
+ parser_symbol_add(*p);
field = *p;
fields.erase(p);
}
@@ -3077,6 +3095,8 @@ symbol_temporaries_free() {
for( auto& elem : temporaries.used ) {
const cbl_field_type_t& type(elem.first);
temporaries_t::fieldset_t& used(elem.second);
+ if( type == FldConditional ) continue;
+
auto freed = std::inserter(temporaries.freed[type],
temporaries.freed[type].begin());
std::copy( used.begin(), used.end(), freed );
@@ -3084,6 +3104,17 @@ symbol_temporaries_free() {
}
}
+#if 0
+void
+temporaries_t::release( cbl_field_type_t type ) {
+ fieldset_t& used[type];
+ auto freed = std::inserter(freed[type],
+ freed[type].begin());
+ std::copy( used.begin(), used.end(), freed );
+ used.clear();
+}
+#endif
+
cbl_field_t *
new_temporary( enum cbl_field_type_t type ) {
return temporaries.acquire(type);
diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h
index bd7f26b0cfc3f0088718aa310b45afc928e7d0af..909063f70934d43372b580aad803753aa9aad5de 100644
--- a/gcc/cobol/symbols.h
+++ b/gcc/cobol/symbols.h
@@ -2091,6 +2091,7 @@ char date_time_fmt( const char input[] );
size_t current_program_index();
const char * current_declarative_section_name();
+size_t end_of_group( size_t igroup );
struct symbol_elem_t * symbol_typedef( size_t program, std::list<const char *> names );
struct symbol_elem_t * symbol_typedef( size_t program, const char name[] );