diff --git a/gcc/cobol/UAT/failsuite.src/typedef.at b/gcc/cobol/UAT/failsuite.src/typedef.at
index b4f234d08d992cbdbc6884b49e1a3569f567831b..1340e560d400e8ffbd1fd9f9368bd7403affb37a 100644
--- a/gcc/cobol/UAT/failsuite.src/typedef.at
+++ b/gcc/cobol/UAT/failsuite.src/typedef.at
@@ -71,125 +71,125 @@ AT_SETUP([TYPEDEF clause])
AT_KEYWORDS([definition EXTERNAL GLOBAL TYPE USAGE listing symbols xref])
AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 AUSGABE-FILE-NAME-T PIC X(50) IS TYPEDEF.
- 01 SOME-VERY-LONG-TYPEDEF-NAME PIC 9999 IS TYPEDEF.
- 01 AUSGABE-FILE-NAME-2T IS TYPEDEF.
- 05 FILLER PIC 9999.
- 05 DETAIL-NO USAGE SOME-VERY-LONG-TYPEDEF-NAME.
- *
- 01 MESSAGE-TEXT-2T IS TYPEDEF.
- 02 AUSGABE-FILE-NAME USAGE AUSGABE-FILE-NAME-T.
- 02 FILLER REDEFINES AUSGABE-FILE-NAME.
- 05 FILLER PIC 9999.
- 02 AUSGABE-FILE-NAME-2 USAGE AUSGABE-FILE-NAME-2T.
- 02 FILLER USAGE AUSGABE-FILE-NAME-T.
- *
- 01 MESSAGE-TEXT-2 EXTERNAL USAGE MESSAGE-TEXT-2T.
-
- 77 OUTPUT-NAME USAGE SOME-VERY-LONG-TYPEDEF-NAME GLOBAL.
-
- 01 Z-MESSAGE-T2 USAGE AUSGABE-FILE-NAME-2T.
- 01 Z-MESSAGE-T3.
- 49 MT3 USAGE MESSAGE-TEXT-2T.
- 49 MT3-REN REDEFINES MT3 USAGE MESSAGE-TEXT-2T.
-
- 01 CALCULUS PIC S9(15)V9(03) IS TYPEDEF.
- 88 NO-DETAIL VALUE ZERO.
- 88 MIN-DETAIL VALUE 0.001.
- 01 USER-TYPE IS TYPEDEF.
- 02 AMOUNT USAGE CALCULUS.
- 02 FILLER OCCURS 100.
- 05 GRP-AMOUNT USAGE CALCULUS.
- 01 USER-VAR USAGE USER-TYPE.
-
- 01 PROC USAGE PROGRAM-POINTER IS TYPEDEF.
- 88 PROC-UNSET VALUE NULL.
- 77 MY-PROC USAGE PROC VALUE NULL.
-
- PROCEDURE DIVISION.
- DISPLAY AUSGABE-FILE-NAME OF MESSAGE-TEXT-2
- DISPLAY DETAIL-NO OF Z-MESSAGE-T2
- DISPLAY AUSGABE-FILE-NAME OF MT3
- DISPLAY OUTPUT-NAME
- MOVE -123.45 TO AMOUNT
- MOVE AMOUNT TO GRP-AMOUNT (1)
- IF MY-PROC = NULL
- SET MY-PROC TO ADDRESS OF PROGRAM "prog".
- GOBACK.
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 AUSGABE-FILE-NAME-T PIC X(50) IS TYPEDEF.
+ 01 SOME-VERY-LONG-TYPEDEF-NAME PIC 9999 IS TYPEDEF.
+ 01 AUSGABE-FILE-NAME-2T IS TYPEDEF.
+ 05 FILLER PIC 9999.
+ 05 DETAIL-NO USAGE SOME-VERY-LONG-TYPEDEF-NAME.
+ *
+ 01 MESSAGE-TEXT-2T IS TYPEDEF.
+ 02 AUSGABE-FILE-NAME USAGE AUSGABE-FILE-NAME-T.
+ 02 FILLER REDEFINES AUSGABE-FILE-NAME.
+ 05 FILLER PIC 9999.
+ 02 AUSGABE-FILE-NAME-2 USAGE AUSGABE-FILE-NAME-2T.
+ 02 FILLER USAGE AUSGABE-FILE-NAME-T.
+ *
+ 01 MESSAGE-TEXT-2 EXTERNAL USAGE MESSAGE-TEXT-2T.
+
+ 77 OUTPUT-NAME USAGE SOME-VERY-LONG-TYPEDEF-NAME GLOBAL.
+
+ 01 Z-MESSAGE-T2 USAGE AUSGABE-FILE-NAME-2T.
+ 01 Z-MESSAGE-T3.
+ 49 MT3 USAGE MESSAGE-TEXT-2T.
+ 49 MT3-REN REDEFINES MT3 USAGE MESSAGE-TEXT-2T.
+
+ 01 CALCULUS PIC S9(15)V9(03) IS TYPEDEF.
+ 88 NO-DETAIL VALUE ZERO.
+ 88 MIN-DETAIL VALUE 0.001.
+ 01 USER-TYPE IS TYPEDEF.
+ 02 AMOUNT USAGE CALCULUS.
+ 02 FILLER OCCURS 100.
+ 05 GRP-AMOUNT USAGE CALCULUS.
+ 01 USER-VAR USAGE USER-TYPE.
+
+ 01 PROC USAGE PROGRAM-POINTER IS TYPEDEF.
+ 88 PROC-UNSET VALUE NULL.
+ 77 MY-PROC USAGE PROC VALUE NULL.
+
+ PROCEDURE DIVISION.
+ DISPLAY AUSGABE-FILE-NAME OF MESSAGE-TEXT-2
+ DISPLAY DETAIL-NO OF Z-MESSAGE-T2
+ DISPLAY AUSGABE-FILE-NAME OF MT3
+ DISPLAY OUTPUT-NAME
+ MOVE -123.45 TO AMOUNT
+ MOVE AMOUNT TO GRP-AMOUNT (1)
+ IF MY-PROC = NULL
+ SET MY-PROC TO ADDRESS OF PROGRAM "prog".
+ GOBACK.
])
AT_DATA([progstd.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 AUSGABE-FILE-NAME-T PIC X(50) IS TYPEDEF.
- 01 DETAIL-NO-T PIC 9999 IS TYPEDEF.
- 01 AUSGABE-FILE-NAME-2T IS TYPEDEF.
- 05 FILLER PIC 9999.
- 05 DETAIL-NO TYPE TO DETAIL-NO-T.
- *
- 01 MESSAGE-TEXT-2T IS TYPEDEF.
- 02 AUSGABE-FILE-NAME TYPE AUSGABE-FILE-NAME-T.
- 02 FILLER REDEFINES AUSGABE-FILE-NAME.
- 05 FILLER PIC 9999.
- 02 AUSGABE-FILE-NAME-2 TYPE AUSGABE-FILE-NAME-2T.
- 02 FILLER TYPE AUSGABE-FILE-NAME-T.
- *
- 01 MESSAGE-TEXT-2 EXTERNAL TYPE MESSAGE-TEXT-2T.
-
- 77 OUTPUT-NAME TYPE TO DETAIL-NO-T GLOBAL.
-
- 01 Z-MESSAGE-T2 TYPE AUSGABE-FILE-NAME-2T.
- 01 Z-MESSAGE-T3.
- 49 MT3 TYPE MESSAGE-TEXT-2T.
- 49 MT3-REN REDEFINES MT3 TYPE MESSAGE-TEXT-2T.
-
- 77 CALCULUS PIC S9(15)V9(03) IS TYPEDEF.
-
- 01 SOME-STRUCT IS TYPEDEF.
- 02 SOME-DATA PIC 9.
- 02 SOME-VALUES OCCURS 3.
- 03 OTHER-DATA PIC X.
- 03 OTHER-VALUES OCCURS 2 PIC 9.
- 77 SOME2-DATA PIC 9.
- 01 SOME-STRUCT2 IS TYPEDEF.
- 02 SOME2-VALUES OCCURS 1 TO 6 DEPENDING ON SOME2-DATA
- DESCENDING KEY SB SA
- INDEXED BY SOME2-INDEX.
- 05 SA PIC X VALUE x'12'.
- 05 SB PIC 9 VALUE 0.
- 05 SDATA PIC X(12).
-
- 01 MY-TEST.
- 02 AMOUNT TYPE CALCULUS.
- 02 FILLER OCCURS 100.
- 05 GRP-AMOUNT TYPE CALCULUS.
- 02 MY-NAME TYPE SOME-STRUCT OCCURS 5.
- 02 MY-NAME2 TYPE SOME-STRUCT2.
- 01 MY-TEST2 TYPE SOME-STRUCT2.
- LINKAGE SECTION.
- 01 MY-STORE TYPE CALCULUS.
-
- PROCEDURE DIVISION USING MY-STORE.
- DISPLAY AUSGABE-FILE-NAME OF MESSAGE-TEXT-2
- DISPLAY DETAIL-NO OF Z-MESSAGE-T2
- DISPLAY AUSGABE-FILE-NAME OF MT3
- DISPLAY OUTPUT-NAME
- SET ADDRESS OF MY-STORE TO NULL
- INITIALIZE MY-NAME(2) GRP-AMOUNT (99)
- INITIALIZE OTHER-VALUES (2, 3, 2)
- SEARCH ALL SOME2-VALUES OF MY-NAME2
- WHEN SA(SOME2-INDEX) = x'12'
- CONTINUE.
- GOBACK.
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 AUSGABE-FILE-NAME-T PIC X(50) IS TYPEDEF.
+ 01 DETAIL-NO-T PIC 9999 IS TYPEDEF.
+ 01 AUSGABE-FILE-NAME-2T IS TYPEDEF.
+ 05 FILLER PIC 9999.
+ 05 DETAIL-NO TYPE TO DETAIL-NO-T.
+ *
+ 01 MESSAGE-TEXT-2T IS TYPEDEF.
+ 02 AUSGABE-FILE-NAME TYPE AUSGABE-FILE-NAME-T.
+ 02 FILLER REDEFINES AUSGABE-FILE-NAME.
+ 05 FILLER PIC 9999.
+ 02 AUSGABE-FILE-NAME-2 TYPE AUSGABE-FILE-NAME-2T.
+ 02 FILLER TYPE AUSGABE-FILE-NAME-T.
+ *
+ 01 MESSAGE-TEXT-2 EXTERNAL TYPE MESSAGE-TEXT-2T.
+
+ 77 OUTPUT-NAME TYPE TO DETAIL-NO-T GLOBAL.
+
+ 01 Z-MESSAGE-T2 TYPE AUSGABE-FILE-NAME-2T.
+ 01 Z-MESSAGE-T3.
+ 49 MT3 TYPE MESSAGE-TEXT-2T.
+ 49 MT3-REN REDEFINES MT3 TYPE MESSAGE-TEXT-2T.
+
+ 77 CALCULUS PIC S9(15)V9(03) IS TYPEDEF.
+
+ 01 SOME-STRUCT IS TYPEDEF.
+ 02 SOME-DATA PIC 9.
+ 02 SOME-VALUES OCCURS 3.
+ 03 OTHER-DATA PIC X.
+ 03 OTHER-VALUES OCCURS 2 PIC 9.
+ 77 SOME2-DATA PIC 9.
+ 01 SOME-STRUCT2 IS TYPEDEF.
+ 02 SOME2-VALUES OCCURS 1 TO 6 DEPENDING ON SOME2-DATA
+ DESCENDING KEY SB SA
+ INDEXED BY SOME2-INDEX.
+ 05 SA PIC X VALUE x'12'.
+ 05 SB PIC 9 VALUE 0.
+ 05 SDATA PIC X(12).
+
+ 01 MY-TEST.
+ 02 AMOUNT TYPE CALCULUS.
+ 02 FILLER OCCURS 100.
+ 05 GRP-AMOUNT TYPE CALCULUS.
+ 02 MY-NAME TYPE SOME-STRUCT OCCURS 5.
+ 02 MY-NAME2 TYPE SOME-STRUCT2.
+ 01 MY-TEST2 TYPE SOME-STRUCT2.
+ LINKAGE SECTION.
+ 01 MY-STORE TYPE CALCULUS.
+
+ PROCEDURE DIVISION USING MY-STORE.
+ DISPLAY AUSGABE-FILE-NAME OF MESSAGE-TEXT-2
+ DISPLAY DETAIL-NO OF Z-MESSAGE-T2
+ DISPLAY AUSGABE-FILE-NAME OF MT3
+ DISPLAY OUTPUT-NAME
+ SET ADDRESS OF MY-STORE TO NULL
+ INITIALIZE MY-NAME(2) GRP-AMOUNT (99)
+ INITIALIZE OTHER-VALUES (2, 3, 2)
+ SEARCH ALL SOME2-VALUES OF MY-NAME2
+ WHEN SA(SOME2-INDEX) = x'12'
+ CONTINUE.
+ GOBACK.
])
-AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], [])
+AT_CHECK([$COMPILE_ONLY -dialect mf prog.cob], [0], [], [])
AT_CLEANUP
AT_SETUP([typedef 1])
@@ -197,17 +197,17 @@ AT_SETUP([typedef 1])
AT_KEYWORDS([typedef])
AT_DATA([badprog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 MESSAGE-TEXT-2T IS TYPEDEF.
- 02 AUSGABE-FILE-NAME PIC X(50).
- 02 F1 USAGE MESSAGE-TEXT-2T.
- 01 MT2 USAGE MESSAGE-TEXT-2T.
- 05 FILLER PIC 9999.
- 01 MT3 TYPE TO MESSAGE-TEXT-2T PIC X.
- 77 OUTPUT-NAME TYPE TO MESSAGE-TEXT-2T.
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 MESSAGE-TEXT-2T IS TYPEDEF.
+ 02 AUSGABE-FILE-NAME PIC X(50).
+ 02 F1 USAGE MESSAGE-TEXT-2T.
+ 01 MT2 USAGE MESSAGE-TEXT-2T.
+ 05 FILLER PIC 9999.
+ 01 MT3 TYPE TO MESSAGE-TEXT-2T PIC X.
+ 77 OUTPUT-NAME TYPE TO MESSAGE-TEXT-2T.
])
@@ -223,46 +223,46 @@ AT_SETUP([SAME AS clause])
AT_KEYWORDS([definition EXTERNAL GLOBAL])
AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 MESSAGE-TEXT-2 EXTERNAL.
- 02 AUSGABE-FILE-NAME PIC X(50).
- 02 FILLER REDEFINES AUSGABE-FILE-NAME.
- 05 FILLER PIC 9999.
- 02 AUSGABE-FILE-NAME-2.
- 05 FILLER PIC 9999.
- 05 DETAIL-NO PIC 9999.
- 02 FILLER SAME AS AUSGABE-FILE-NAME.
-
- 77 OUTPUT-NAME SAME AS DETAIL-NO GLOBAL.
-
- 01 Z-MESSAGE-T2 SAME AS AUSGABE-FILE-NAME-2.
- 01 Z-MESSAGE-T3.
- 49 MT3 SAME AS MESSAGE-TEXT-2.
- 49 MT3-REN REDEFINES MT3 SAME AS MESSAGE-TEXT-2.
-
- PROCEDURE DIVISION.
- DISPLAY AUSGABE-FILE-NAME OF MESSAGE-TEXT-2
- DISPLAY DETAIL-NO OF Z-MESSAGE-T2
- DISPLAY AUSGABE-FILE-NAME OF MT3
- DISPLAY OUTPUT-NAME
- GOBACK.
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 MESSAGE-TEXT-2 EXTERNAL.
+ 02 AUSGABE-FILE-NAME PIC X(50).
+ 02 FILLER REDEFINES AUSGABE-FILE-NAME.
+ 05 FILLER PIC 9999.
+ 02 AUSGABE-FILE-NAME-2.
+ 05 FILLER PIC 9999.
+ 05 DETAIL-NO PIC 9999.
+ 02 FILLER SAME AS AUSGABE-FILE-NAME.
+
+ 77 OUTPUT-NAME SAME AS DETAIL-NO GLOBAL.
+
+ 01 Z-MESSAGE-T2 SAME AS AUSGABE-FILE-NAME-2.
+ 01 Z-MESSAGE-T3.
+ 49 MT3 SAME AS MESSAGE-TEXT-2.
+ 49 MT3-REN REDEFINES MT3 SAME AS MESSAGE-TEXT-2.
+
+ PROCEDURE DIVISION.
+ DISPLAY AUSGABE-FILE-NAME OF MESSAGE-TEXT-2
+ DISPLAY DETAIL-NO OF Z-MESSAGE-T2
+ DISPLAY AUSGABE-FILE-NAME OF MT3
+ DISPLAY OUTPUT-NAME
+ GOBACK.
])
AT_DATA([badprog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- 01 MESSAGE-TEXT-2.
- 02 AUSGABE-FILE-NAME PIC X(50).
- 02 F1 SAME AS MESSAGE-TEXT-2.
- 01 MT2 SAME AS MESSAGE-TEXT-2.
- 05 FILLER PIC 9999.
- 01 MT3 SAME AS MESSAGE-TEXT-2 PIC X.
- 77 OUTPUT-NAME SAME AS MESSAGE-TEXT-2.
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 MESSAGE-TEXT-2.
+ 02 AUSGABE-FILE-NAME PIC X(50).
+ 02 F1 SAME AS MESSAGE-TEXT-2.
+ 01 MT2 SAME AS MESSAGE-TEXT-2.
+ 05 FILLER PIC 9999.
+ 01 MT3 SAME AS MESSAGE-TEXT-2 PIC X.
+ 77 OUTPUT-NAME SAME AS MESSAGE-TEXT-2.
])
AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], [])
@@ -286,136 +286,136 @@ AT_SETUP([typedef 1])
AT_KEYWORDS([typedef])
AT_DATA([prog.cob], [
- IDENTIFICATION DIVISION.
- PROGRAM-ID. prog.
- DATA DIVISION.
- WORKING-STORAGE SECTION.
- *> D.22.7.1 Example of validation of USAGE DISPLAY items
- *>
- *>*************************************************************
- *>Description of target record (note: should be possible to define later)
- *>*************************************************************
- *>This is set up by the optional DESTINATION clauses defined
- *>in the input record;
- *>if a format error is found, a default value is stored instead.
- 01 TARGET-AREA.
- 05 OUT-NAME PIC X(20).
- 05 OUT-WEEK PIC 99 COMP OCCURS 5.
- *>*************************************************************
- *>Validated items
- *>*************************************************************
- 01 INPUT-RECORD.
- *>PIC 99 checks that IN-TYPE is 2 characters numeric;
- 03 IN-TYPE PIC 99
- *>if IN-TYPE fails the PICTURE check, it is assumed to be 1;
- *>without a DEFAULT clause, the assumed value would here be 0.
- DEFAULT 1.
- *>PRESENT WHEN states the condition for this format to be used.
- 03 IN-REC-FORMAT-1 PRESENT WHEN IN-TYPE = 0 OR 1 OR 2.
- *>PICTURE A(20) checks for 20 alphabetic (or space) characters.
- 05 IN-NAME PIC A(20)
- *>PRESENT WHEN defines when the validation clauses for this data item apply:
- PRESENT WHEN IN-TYPE = 0 OR 1
- *>CLASS checks each character for a class defined in SPECIAL-NAMES
- *>or a predefined class
- CLASS IS ALPHABETIC-UPPER
- *>DESTINATION moves this item (or spaces if not alpha) to OUT-NAME.
- DESTINATION OUT-NAME.
- *>PRESENT WHEN checks whether the item is "blank" under this condition
- 05 FILLER REDEFINES IN-NAME PIC X(20) *> should PIC be optional?
- PRESENT WHEN IN-TYPE = 2
- DESTINATION OUT-NAME.
- 88 VALUE SPACES IS VALID.
- *>The values of IN-WEEK are checked to be in non-descending order.
- 05 IN-WEEK PIC 99 OCCURS 5
- VARYING IN-WEEK-NO FROM 1, IN-NEXT-WEEK-NO FROM 2
- INVALID WHEN IN-WEEK-NO < 5
- AND IN-WEEK (IN-WEEK-NO) > IN-WEEK (IN-NEXT-WEEK-NO)
- *>OUT-WEEK (1) to (5) will hold the values of IN-WEEK (1) to (5),
- *>or zero for any one that failed the format (PICTURE) test.
- DESTINATION OUT-WEEK (IN-WEEK-NO).
- *>The 88-level INVALID entries check for invalid ranges of values.
- 88 VALUES 0, 53 THRU 99 ARE INVALID.
- *>REDEFINES and another PRESENT WHEN define an alternate format.
- 03 IN-REC-FORMAT-2 REDEFINES IN-REC-FORMAT-1
- PRESENT WHEN IN-TYPE > 2.
- *>IN-PAY has insertion characters that must be present on input.
- 05 IN-PAY PIC ZZ,ZZZ.ZZ.
- *>The 88-level VALID entries check for valid ranges of values;
- *>the condition-name, if present, may be used in the usual way.
- *>The following assume that DECIMAL POINT IS COMMA is not specified.
- 88 IN-PAY-OK VALUES "10,000.00" THRU "20,000.00" ARE VALID.
- *>88-level entries may also have a condition attached.
- 88 VALUES "20,000.01" THRU "30,000.00" ARE VALID
- WHEN IN-TYPE = 8.
- *>exceptional cases can be specified using PRESENT WHEN
- 05 IN-CODE PIC AX(3)9(4)
- PRESENT WHEN IN-CODE NOT = "UNKNOWN".
- 05 FILLER PIC X(13).
- *>
- *>*************************************************************
- *> Description of error messages
- *>*************************************************************
- *>Error messages or flags are set up or cleared automatically
- *>when the VALIDATE statement is executed; the programmer chooses
- *>where they go and what messages or values they contain;
- *>they need not be contiguous as they are in this example.
- 01 VALIDATE-MESSAGES.
- 03 PIC X(40) VALIDATE-STATUS "Unknown Record Type - 1 assumed"
- WHEN ERROR FOR IN-TYPE
- *> more than one VALIDATE-STATUS clause may be defined in one entry;
- *> a NO ERROR phrase produces a message when the item is valid.
- VALIDATE-STATUS "Record type Accepted"
- WHEN NO ERROR FOR IN-TYPE.
- *> The VALIDATE-STATUS clause can pinpoint the stage of the failed check.
- 03 PIC X(40) VALIDATE-STATUS "Name not alphabetic"
- WHEN ERROR ON FORMAT FOR IN-NAME
- VALIDATE-STATUS "Lower-case not allowed in name"
- WHEN ERROR ON CONTENT FOR IN-NAME
- VALIDATE-STATUS "Name not allowed in this case"
- WHEN ERROR ON RELATION FOR IN-NAME.
- *> If no message is stored, spaces will be stored in these cases.
- *> Errors may also be indicated by flags;
- *> they may also refer to a table of input items.
- 03 W-ERROR-FLAG PIC 9 COMP OCCURS 5
- VALIDATE-STATUS 1 WHEN ERROR FOR IN-WEEK.
- *>An EC-VALIDATE (nonfatal) exception is also set if the
- *>VALIDATE statement detects an invalid condition.
-
-
- *> From D.22.7.2 Example of validation of non-display items:
- 01 MIXED-GROUP TYPEDEF STRONG.
- 05 FLD-1 PIC S9(4) USAGE COMP.
- 05 FLD-2 PIC S9(7) USAGE PACKED-DECIMAL.
- 05 FLD-3 PIC 1(8) USAGE BIT ALIGNED.
- 05 PTR-1 USAGE INDEX.
- 05 PTR-2 USAGE OBJECT REFERENCE.
- 05 TXT-1 PIC N(12) USAGE NATIONAL.
- 01 MY-MIXED-GROUP TYPE MIXED-GROUP.
-
-
- *>
- *>*************************************************************
- *>Execution of the VALIDATE statement
- *>*************************************************************
- PROCEDURE DIVISION.
-
- *>A single VALIDATE statement performs all the actions implied
- *>in the above data descriptions.
- VALIDATE INPUT-RECORD
- *>After this statement has been executed:
- *>(1) the input record is unchanged;
- *>(2) input items are moved automatically to the target area;
- *>(3) error messages are set up wherever specified in the program.
- *>
-
- *> From D.22.7.2 Example of validation of non-display items:
- *>A declarative section could be used instead of VALIDATE-STATUS clauses
- *>especially if errors are not expected.
- *>> TURN EC-VALIDATE CHECKING ON
- VALIDATE MY-MIXED-GROUP
-
- GOBACK.
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. prog.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ *> D.22.7.1 Example of validation of USAGE DISPLAY items
+ *>
+ *>*************************************************************
+ *>Description of target record (note: should be possible to define later)
+ *>*************************************************************
+ *>This is set up by the optional DESTINATION clauses defined
+ *>in the input record;
+ *>if a format error is found, a default value is stored instead.
+ 01 TARGET-AREA.
+ 05 OUT-NAME PIC X(20).
+ 05 OUT-WEEK PIC 99 COMP OCCURS 5.
+ *>*************************************************************
+ *>Validated items
+ *>*************************************************************
+ 01 INPUT-RECORD.
+ *>PIC 99 checks that IN-TYPE is 2 characters numeric;
+ 03 IN-TYPE PIC 99
+ *>if IN-TYPE fails the PICTURE check, it is assumed to be 1;
+ *>without a DEFAULT clause, the assumed value would here be 0.
+ DEFAULT 1.
+ *>PRESENT WHEN states the condition for this format to be used.
+ 03 IN-REC-FORMAT-1 PRESENT WHEN IN-TYPE = 0 OR 1 OR 2.
+ *>PICTURE A(20) checks for 20 alphabetic (or space) characters.
+ 05 IN-NAME PIC A(20)
+ *>PRESENT WHEN defines when the validation clauses for this data item apply:
+ PRESENT WHEN IN-TYPE = 0 OR 1
+ *>CLASS checks each character for a class defined in SPECIAL-NAMES
+ *>or a predefined class
+ CLASS IS ALPHABETIC-UPPER
+ *>DESTINATION moves this item (or spaces if not alpha) to OUT-NAME.
+ DESTINATION OUT-NAME.
+ *>PRESENT WHEN checks whether the item is "blank" under this condition
+ 05 FILLER REDEFINES IN-NAME PIC X(20) *> should PIC be optional?
+ PRESENT WHEN IN-TYPE = 2
+ DESTINATION OUT-NAME.
+ 88 VALUE SPACES IS VALID.
+ *>The values of IN-WEEK are checked to be in non-descending order.
+ 05 IN-WEEK PIC 99 OCCURS 5
+ VARYING IN-WEEK-NO FROM 1, IN-NEXT-WEEK-NO FROM 2
+ INVALID WHEN IN-WEEK-NO < 5
+ AND IN-WEEK (IN-WEEK-NO) > IN-WEEK (IN-NEXT-WEEK-NO)
+ *>OUT-WEEK (1) to (5) will hold the values of IN-WEEK (1) to (5),
+ *>or zero for any one that failed the format (PICTURE) test.
+ DESTINATION OUT-WEEK (IN-WEEK-NO).
+ *>The 88-level INVALID entries check for invalid ranges of values.
+ 88 VALUES 0, 53 THRU 99 ARE INVALID.
+ *>REDEFINES and another PRESENT WHEN define an alternate format.
+ 03 IN-REC-FORMAT-2 REDEFINES IN-REC-FORMAT-1
+ PRESENT WHEN IN-TYPE > 2.
+ *>IN-PAY has insertion characters that must be present on input.
+ 05 IN-PAY PIC ZZ,ZZZ.ZZ.
+ *>The 88-level VALID entries check for valid ranges of values;
+ *>the condition-name, if present, may be used in the usual way.
+ *>The following assume that DECIMAL POINT IS COMMA is not specified.
+ 88 IN-PAY-OK VALUES "10,000.00" THRU "20,000.00" ARE VALID.
+ *>88-level entries may also have a condition attached.
+ 88 VALUES "20,000.01" THRU "30,000.00" ARE VALID
+ WHEN IN-TYPE = 8.
+ *>exceptional cases can be specified using PRESENT WHEN
+ 05 IN-CODE PIC AX(3)9(4)
+ PRESENT WHEN IN-CODE NOT = "UNKNOWN".
+ 05 FILLER PIC X(13).
+ *>
+ *>*************************************************************
+ *> Description of error messages
+ *>*************************************************************
+ *>Error messages or flags are set up or cleared automatically
+ *>when the VALIDATE statement is executed; the programmer chooses
+ *>where they go and what messages or values they contain;
+ *>they need not be contiguous as they are in this example.
+ 01 VALIDATE-MESSAGES.
+ 03 PIC X(40) VALIDATE-STATUS "Unknown Record Type - 1 assumed"
+ WHEN ERROR FOR IN-TYPE
+ *> more than one VALIDATE-STATUS clause may be defined in one entry;
+ *> a NO ERROR phrase produces a message when the item is valid.
+ VALIDATE-STATUS "Record type Accepted"
+ WHEN NO ERROR FOR IN-TYPE.
+ *> The VALIDATE-STATUS clause can pinpoint the stage of the failed check.
+ 03 PIC X(40) VALIDATE-STATUS "Name not alphabetic"
+ WHEN ERROR ON FORMAT FOR IN-NAME
+ VALIDATE-STATUS "Lower-case not allowed in name"
+ WHEN ERROR ON CONTENT FOR IN-NAME
+ VALIDATE-STATUS "Name not allowed in this case"
+ WHEN ERROR ON RELATION FOR IN-NAME.
+ *> If no message is stored, spaces will be stored in these cases.
+ *> Errors may also be indicated by flags;
+ *> they may also refer to a table of input items.
+ 03 W-ERROR-FLAG PIC 9 COMP OCCURS 5
+ VALIDATE-STATUS 1 WHEN ERROR FOR IN-WEEK.
+ *>An EC-VALIDATE (nonfatal) exception is also set if the
+ *>VALIDATE statement detects an invalid condition.
+
+
+ *> From D.22.7.2 Example of validation of non-display items:
+ 01 MIXED-GROUP TYPEDEF STRONG.
+ 05 FLD-1 PIC S9(4) USAGE COMP.
+ 05 FLD-2 PIC S9(7) USAGE PACKED-DECIMAL.
+ 05 FLD-3 PIC 1(8) USAGE BIT ALIGNED.
+ 05 PTR-1 USAGE INDEX.
+ 05 PTR-2 USAGE OBJECT REFERENCE.
+ 05 TXT-1 PIC N(12) USAGE NATIONAL.
+ 01 MY-MIXED-GROUP TYPE MIXED-GROUP.
+
+
+ *>
+ *>*************************************************************
+ *>Execution of the VALIDATE statement
+ *>*************************************************************
+ PROCEDURE DIVISION.
+
+ *>A single VALIDATE statement performs all the actions implied
+ *>in the above data descriptions.
+ VALIDATE INPUT-RECORD
+ *>After this statement has been executed:
+ *>(1) the input record is unchanged;
+ *>(2) input items are moved automatically to the target area;
+ *>(3) error messages are set up wherever specified in the program.
+ *>
+
+ *> From D.22.7.2 Example of validation of non-display items:
+ *>A declarative section could be used instead of VALIDATE-STATUS clauses
+ *>especially if errors are not expected.
+ *>> TURN EC-VALIDATE CHECKING ON
+ VALIDATE MY-MIXED-GROUP
+
+ GOBACK.
])
AT_CLEANUP
diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc
index 16a647c0547e2b6ff30c96a3ecfcea5962f510d4..d25008bf823837b60283e791e9dc1bf4c4a0ba26 100644
--- a/gcc/cobol/genapi.cc
+++ b/gcc/cobol/genapi.cc
@@ -11448,7 +11448,7 @@ parser_set_pointers( size_t ntgt, cbl_refer_t *tgts, cbl_refer_t source )
gcc_assert( tgts[i].field->attr & (linkage_e | based_e) );
}
- if( source.field && !source.addr_of )
+ if( (source.field || source.prog_func) && !source.addr_of )
{
// When not ADDRESS OF SOURCE, the variable must be a POINTER
gcc_assert( source.field->type == FldPointer );
diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h
index 7afd147950d6355846a4f127cb7382a3fa81941d..30576cf26bfd680046a11a52c5577d6b3f0387c9 100644
--- a/gcc/cobol/genapi.h
+++ b/gcc/cobol/genapi.h
@@ -146,7 +146,7 @@ parser_divide( struct cbl_refer_t quotient,
struct cbl_refer_t divisor,
struct cbl_refer_t dividend,
enum cbl_round_t = truncation_e,
- struct cbl_refer_t remainder = cbl_refer_t(NULL));
+ struct cbl_refer_t remainder = cbl_refer_t());
void
parser_exponentiation( cbl_refer_t cref,
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index c67e5a024c589a4656b9758c14d9efbd0b3d2d2d..0a941575ff94bf29eea67dac8015cabb2edb4bb9 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -2836,6 +2836,31 @@ data_descr1: level_name
}
}
+ | LEVEL88 NAME /* VALUE */ NULLPTR
+ {
+ struct cbl_field_t field = { 0,
+ FldClass, FldInvalid, 0, 0, 0, 88, nonarray, yylineno, "",
+ 0, { 0,0,0,0, NULL, NULL, { NULL }, { NULL } }, NULL };
+ if( !namcpy(field.name, $2) ) YYERROR;
+
+ auto fig = constant_of(constant_index(NULLS));
+ struct cbl_domain_t *domain = new cbl_domain_t[2];
+
+ domain[0] = fig;
+
+ field.data.domain = domain;
+
+ if( ($$ = field_add(&field)) == NULL ) {
+ yyerror("failed level 88");
+ YYERROR;
+ }
+ auto parent = cbl_field_of(symbol_at($$->parent));
+ if( parent->type != FldPointer ) {
+ yyerrorv("error: LEVEL 88 %s VALUE NULLS invalid for "
+ "%02d %s, which is not a POINTER",
+ $$->name, parent->level, parent->name);
+ }
+ }
| LEVEL88 NAME VALUE domains
{
struct cbl_field_t field = { 0,
@@ -3010,10 +3035,12 @@ data_descr1: level_name
#endif
// SIGN clause valid only with "S" in picture
if( $field->type == FldNumericDisplay && !is_signable($field) ) {
- static const uint32_t sign_attrs = leading_e | separate_e;
+ static const size_t sign_attrs = leading_e | separate_e;
+ static_assert(sizeof(sign_attrs) == sizeof($field->attr),
+ "size matters");
// remove inapplicable inherited sign attributes
- uint32_t group_sign = group_attr($field) & sign_attrs;
+ size_t group_sign = group_attr($field) & sign_attrs;
$field->attr &= ~group_sign;
if( $field->attr & sign_attrs ) {
@@ -3458,7 +3485,7 @@ alphanum_pic: alphanum_part {
| alphanum_pic alphanum_part
{
if( $2.attr != all_alpha_e ) {
- current_field()->attr &= ~all_alpha_e;
+ current_field()->attr &= ~size_t(all_alpha_e);
}
$$ += $2.nbyte;
}
@@ -3807,7 +3834,7 @@ sign_clause: sign_is sign_leading sign_separate
if( $sign_leading ) {
field->attr |= leading_e;
} else {
- field->attr &= ~leading_e; // turn off in case inherited
+ field->attr &= ~size_t(leading_e); // turn off in case inherited
field->attr |= signable_e;
}
if( $sign_separate ) field->attr |= separate_e;
@@ -6984,6 +7011,11 @@ set_tgts: set_tgt {
;
set_operand: set_tgt
| signed_literal { $$ = new_reference($1); }
+ | ADDRESS of PROGRAM_kw namestr
+ {
+ auto label = symbol_program(0, $namestr.data);
+ $$ = new cbl_refer_t( label );
+ }
;
set_tgt: scalar
| ADDRESS of scalar { $$ = $scalar; $$->addr_of = true; }
@@ -6994,6 +7026,13 @@ set: SET set_tgts[tgts] TO set_operand[src]
statement_begin(@1, SET);
switch( set_operand_type(*$src) ) {
+ case FldInvalid:
+ if( ! ($src->prog_func && $src->addr_of) ) {
+ yyerrorv("SET source operand '%s' is invalid", $src->name());
+ YYERROR;
+ break;
+ }
+ __attribute__((fallthrough));
case FldPointer:
if( !valid_set_targets(*$tgts, true) ) {
YYERROR;
@@ -7001,11 +7040,6 @@ set: SET set_tgts[tgts] TO set_operand[src]
ast_set_pointers($tgts->targets, *$src);
break;
- case FldInvalid:
- yyerrorv("SET source operand '%s' is invalid", $src->name());
- YYERROR;
- break;
-
case FldIndex:
case FldNumericDisplay:
case FldNumericBinary:
diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h
index f0652c07b48d166053b9899d5435575e33a1db1a..c063508d7cc63dc50b8f30778a28bb7fbbb02d4a 100644
--- a/gcc/cobol/parse_ante.h
+++ b/gcc/cobol/parse_ante.h
@@ -1126,7 +1126,7 @@ struct unstring_tgt_t {
}
private:
static cbl_refer_t maybe_empty( cbl_refer_t *p ) {
- return p? *p : cbl_refer_t(NULL);
+ return p? *p : cbl_refer_t();
}
};
@@ -2653,11 +2653,15 @@ parser_move_carefully( const char */*F*/, int /*L*/,
static void
ast_set_pointers( const list<cbl_num_result_t>& tgts, cbl_refer_t src ) {
assert(!tgts.empty());
- assert(src.field);
+ assert(src.field || src.prog_func);
size_t nptr = tgts.size();
cbl_refer_t ptrs[nptr];
std::transform( tgts.begin(), tgts.end(), ptrs, cbl_num_result_t::refer_of );
+ if( src.prog_func ) {
+ yywarnv("%s: RJD: source ('%s') is program pointer, not data",
+ __func__, src.prog_func->name);
+ }
parser_set_pointers(nptr, ptrs, src);
}
diff --git a/gcc/cobol/scan.l b/gcc/cobol/scan.l
index a84b366a7f5e09ef605918132fbe96133730b4eb..79eba81bf19a581ccf28f3e90600f3ed41a072ba 100644
--- a/gcc/cobol/scan.l
+++ b/gcc/cobol/scan.l
@@ -1054,6 +1054,7 @@ USE({SPC}FOR)? { return USE; }
TO { return TO; }
TRAILING { return TRAILING; }
TRUE { return TRUE_kw; }
+ TYPE { return TYPE; }
TYPEDEF { return TYPEDEF; }
VARYING { return VARYING; }
VOLATILE { return VOLATILE; }
diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h
index 2acb546b0c8bb7a4292f6afec7d040ca017e1aaf..293e66f748972c9092531790ff24af6f7be5e48f 100644
--- a/gcc/cobol/symbols.h
+++ b/gcc/cobol/symbols.h
@@ -570,6 +570,7 @@ 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;
@@ -845,6 +846,7 @@ cbl_file_mode_str( cbl_file_mode_t mode ) {
struct cbl_refer_t {
cbl_field_t *field;
+ cbl_label_t *prog_func;
bool all, addr_of;
uint32_t nsubscript;
cbl_refer_t *subscripts; // indices
@@ -852,25 +854,34 @@ struct cbl_refer_t {
tree refer_decl_node; // For the cblc_refer_t structure
cbl_refer_t( cbl_field_t *field = NULL, bool all = false )
- : field(field), all(all), addr_of(false)
+ : field(field), prog_func(NULL)
+ , all(all), addr_of(false)
, nsubscript(0), subscripts(NULL), refmod(NULL)
, refer_decl_node(NULL)
{}
cbl_refer_t( cbl_field_t *field, cbl_span_t& refmod )
- : field(field), all(false), addr_of(false)
+ : field(field), prog_func(NULL)
+ , all(false), addr_of(false)
, nsubscript(0), subscripts(NULL), refmod(refmod)
, refer_decl_node(NULL)
{}
cbl_refer_t( cbl_field_t *field,
size_t nsubscript, cbl_refer_t *subscripts,
cbl_span_t refmod = cbl_span_t(NULL) )
- : field(field), all(false), addr_of(false)
+ : field(field), prog_func(NULL)
+ , all(false), addr_of(false)
, nsubscript(nsubscript) , subscripts( new cbl_refer_t[nsubscript] )
, refmod(refmod)
, refer_decl_node(NULL)
{
std::copy(subscripts, subscripts + nsubscript, this->subscripts);
}
+ explicit cbl_refer_t( cbl_label_t *prog_func, bool addr_of = true )
+ : field(NULL), prog_func(prog_func)
+ , all(false), addr_of(addr_of)
+ , nsubscript(0), subscripts(NULL), refmod(cbl_span_t(NULL))
+ , refer_decl_node(NULL)
+ {}
static cbl_refer_t *empty();
diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc
index 733a71efec121cf96eab257258169d5bc2c20b50..7c2e63b3e375dbc92d7962f08afdb98423ae6a59 100644
--- a/gcc/cobol/util.cc
+++ b/gcc/cobol/util.cc
@@ -579,7 +579,7 @@ symbol_field_index_set( cbl_field_t *field ) {
field->data = data;
field->type = FldIndex;
- field->attr &= ~signable_e;
+ field->attr &= ~size_t(signable_e);
return field;
}
@@ -600,7 +600,7 @@ symbol_field_type_update( cbl_field_t *field,
static const cbl_field_data_t data = {0, 8, 0, 0,
NULL, NULL, {NULL}, {NULL}};
field->data = data;
- field->attr &= ~ signable_e;
+ field->attr &= ~size_t(signable_e);
}
return true;
default:
@@ -964,6 +964,7 @@ cbl_refer_t::str() const {
const char *
cbl_refer_t::name() const {
char *output;
+ if( prog_func ) return prog_func->name;
asprintf( &output, "%s", field? field->name : "(none)" );
return output;
}