Skip to content

Commit d5563bf

Browse files
fm-117fm-117
authored
WI #1916 Check WHEN condition in binary SEARCH statements (#2021)
1 parent 8312290 commit d5563bf

File tree

7 files changed

+522
-72
lines changed

7 files changed

+522
-72
lines changed

‎TypeCobol.Test/Parser/Programs/Cobol85/ProgramPGM.txt‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ Line 40[14,24] <37, Warning, General> - Warning: Dot expected at the end of PROG
1010
Line 60[22,25] <27, Error, Syntax> - Syntax error : Currency symbol must be one single character.
1111
Line 79[4,4] <27, Error, Syntax> - Syntax error : Group item x cannot have a "PICTURE" OffendingSymbol=[4,4:x]<UserDefinedWord>
1212
Line 106[16,19] <27, Error, Syntax> - Syntax error : mismatched input 'TYPE' expecting {symbol, special register, keyword} RuleStack=codeElement>moveStatement>moveSimple, OffendingSymbol=[16,19:TYPE]<TYPE>
13+
Line 114[3,22] <27, Error, Syntax> - Syntax error : Cannot SEARCH in 'num', data item is not a table.
1314
Line 121[1,16] <37, Warning, General> - Warning: Paragraph 'EMPTY-PARAGRAPH' is empty
1415

1516
--- Program ---

‎TypeCobol.Test/Parser/Programs/Cobol85/SearchAllWhen.rdz.cbl‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,7 @@
3030
SEARCH ALL DSRCE-TAB
3131
AT END
3232
DISPLAY 'VALUE NOT FOUND'
33-
* Ok
33+
* Ko DSRCE-KEY-A (Idx) must appear on left side
3434
WHEN WS-KEY = DSRCE-KEY-A (Idx)
3535
DISPLAY 'VALUE FOUND'
3636
END-SEARCH

‎TypeCobol.Test/Parser/Programs/Cobol85/SearchAllWhen.rdzMix.txt‎

Lines changed: 8 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,8 @@
3030
SEARCH ALL DSRCE-TAB
3131
AT END
3232
DISPLAY 'VALUE NOT FOUND'
33-
* Ok
33+
* Ko DSRCE-KEY-A (Idx) must appear on left side
34+
Line 34[15,45] <27, Error, Syntax> - Syntax error : Left side operand of a WHEN condition must use first index of the table and at least one of declared keys.
3435
WHEN WS-KEY = DSRCE-KEY-A (Idx)
3536
DISPLAY 'VALUE FOUND'
3637
END-SEARCH
@@ -39,7 +40,7 @@
3940
AT END
4041
DISPLAY 'VALUE NOT FOUND'
4142
* Ko DSRCE-SRCE-VAL is not a key of the table searched
42-
Line 42[15,48] <27, Error, Syntax> - Syntax error : When subscripting, first index declared for the table and at least one of declared keys must be used.
43+
Line 42[15,48] <27, Error, Syntax> - Syntax error : 'DSRCE-SRCE-VAL' is not a sorting key of table 'DSRCE-TAB'.
4344
WHEN DSRCE-SRCE-VAL (Idx) = WS-KEY
4445
DISPLAY 'VALUE FOUND'
4546
END-SEARCH
@@ -48,7 +49,7 @@ Line 42[15,48] <27, Error, Syntax> - Syntax error : When subscripting, first ind
4849
AT END
4950
DISPLAY 'VALUE NOT FOUND'
5051
* Ko DSRCE-SRCE-VAL is not a key of the table searched
51-
Line 50[15,48] <27, Error, Syntax> - Syntax error : When subscripting, first index declared for the table and at least one of declared keys must be used.
52+
Line 50[15,48] <27, Error, Syntax> - Syntax error : Left side operand of a WHEN condition must use first index of the table and at least one of declared keys.
5253
WHEN WS-KEY = DSRCE-SRCE-VAL (Idx)
5354
DISPLAY 'VALUE FOUND'
5455
END-SEARCH
@@ -65,7 +66,7 @@ Line 50[15,48] <27, Error, Syntax> - Syntax error : When subscripting, first ind
6566
SEARCH ALL DSRCE-TAB
6667
AT END
6768
DISPLAY 'VALUE NOT FOUND'
68-
Line 66[15,49] <27, Error, Syntax> - Syntax error : When subscripting, first index declared for the table and at least one of declared keys must be used.
69+
Line 66[15,49] <27, Error, Syntax> - Syntax error : 'DSRCE-SRCE-VAL' is not a sorting key of table 'DSRCE-TAB'.
6970
WHEN DSRCE-KEY-A (Idx) = WS-KEY
7071
* Ko DSRCE-SRCE-VAL is not a key of the table searched
7172
AND DSRCE-SRCE-VAL (Idx) = WS-KEY2
@@ -76,7 +77,7 @@ Line 66[15,49] <27, Error, Syntax> - Syntax error : When subscripting, first ind
7677
AT END
7778
DISPLAY 'VALUE NOT FOUND'
7879
* Ko DSRCE-KEY-A is not indexed by the first index of DSRCE-TAB
79-
Line 76[15,46] <27, Error, Syntax> - Syntax error : When subscripting, first index declared for the table and at least one of declared keys must be used.
80+
Line 76[15,46] <27, Error, Syntax> - Syntax error : When subscripting, only first index declared for the table is allowed.
8081
WHEN DSRCE-KEY-A (Idx2) = WS-KEY
8182
DISPLAY 'VALUE FOUND'
8283
END-SEARCH
@@ -85,15 +86,15 @@ Line 76[15,46] <27, Error, Syntax> - Syntax error : When subscripting, first ind
8586
AT END
8687
DISPLAY 'VALUE NOT FOUND'
8788
* Ko DSRCE-KEY-A is not indexed by the first index of DSRCE-TAB
88-
Line 84[15,48] <27, Error, Syntax> - Syntax error : When subscripting, first index declared for the table and at least one of declared keys must be used.
89+
Line 84[15,48] <27, Error, Syntax> - Syntax error : When subscripting, only first index declared for the table is allowed.
8990
WHEN DSRCE-KEY-A (I) = WS-SRCE-VAL
9091
DISPLAY 'VALUE FOUND'
9192
END-SEARCH
9293

9394
SEARCH ALL DSRCE-TAB
9495
AT END
9596
DISPLAY 'VALUE NOT FOUND'
96-
Line 91[15,47] <27, Error, Syntax> - Syntax error : When subscripting, first index declared for the table and at least one of declared keys must be used.
97+
Line 91[15,47] <27, Error, Syntax> - Syntax error : When subscripting, only first index declared for the table is allowed.
9798
WHEN DSRCE-KEY-A (Idx) = WS-KEY
9899
* Ko DSRCE-KEY-D is not indexed by the first index of DSRCE-TAB
99100
AND DSRCE-KEY-D (Idx2) = WS-KEY2

‎TypeCobol.Test/Parser/Programs/Cobol85/SearchAllWhen2.rdz.cbl‎

Lines changed: 128 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,128 @@
1+
IDENTIFICATION DIVISION.
2+
PROGRAM-ID. Pgm.
3+
DATA DIVISION.
4+
WORKING-STORAGE SECTION.
5+
6+
01 NotATable PIC X(20).
7+
8+
01 TableWithoutKey.
9+
05 tab1 OCCURS 20.
10+
10 tab1-item PIC X.
11+
12+
01 TableWithoutIndex.
13+
05 tab2 OCCURS 20
14+
ASCENDING KEY IS tab2-key.
15+
10 tab2-key PIC 99.
16+
10 tab2-item PIC XX.
17+
18+
01 MultiDim1.
19+
05 tab3 OCCURS 10.
20+
10 tab3-1 OCCURS 10
21+
ASCENDING KEY IS tab3-1-key
22+
INDEXED BY tab3-1-idx.
23+
15 tab3-1-key PIC 99.
24+
15 tab3-1-item PIC XX.
25+
26+
01 test-value PIC XX.
27+
01 some-value PIC XX.
28+
29+
01 MultiDim2.
30+
05 tab4 OCCURS 10
31+
INDEXED BY tab4-idx1 tab4-idx2 tab4-idx3.
32+
10 tab4-1 OCCURS 10
33+
INDEXED BY tab4-1-idx1 tab4-1-idx2 tab4-1-idx3.
34+
15 tab4-2 OCCURS 10
35+
ASCENDING KEY IS tab4-2-key-asc
36+
DESCENDING KEY IS tab4-2-key-desc
37+
INDEXED BY tab4-2-idx1 tab4-2-idx2
38+
tab4-2-idx3.
39+
20 tab4-2-key-asc PIC 99.
40+
20 tab4-2-key-desc PIC 99.
41+
20 tab4-2-item PIC XX.
42+
43+
01 some-key-value-1 PIC 99.
44+
01 some-key-value-2 PIC 99.
45+
46+
01 MultiDim3.
47+
05 tab5 OCCURS 10.
48+
10 tab5-1 OCCURS 10.
49+
15 tab5-2 OCCURS 10
50+
ASCENDING KEY IS tab5-2-key.
51+
20 tab5-2-key PIC 99.
52+
20 tab5-2-item PIC XX.
53+
54+
PROCEDURE DIVISION.
55+
*KO search on something that is not a table
56+
SEARCH ALL NotATable
57+
WHEN test-value = some-value
58+
DISPLAY 'Ok'
59+
END-SEARCH
60+
*KO binary search on a table without key
61+
SEARCH ALL tab1
62+
WHEN test-value = some-value
63+
DISPLAY 'Ok'
64+
END-SEARCH
65+
*KO binary search on a table without index
66+
SEARCH ALL tab2
67+
WHEN test-value = some-value
68+
DISPLAY 'Ok'
69+
END-SEARCH
70+
*KO binary search on a table with parent table without index
71+
SEARCH ALL tab3-1
72+
WHEN test-value = some-value
73+
DISPLAY 'Ok'
74+
END-SEARCH
75+
*KO all keys defined before any referenced key must be used
76+
SEARCH ALL tab4-2
77+
WHEN tab4-2-key-desc (tab4-idx1 tab4-1-idx1 tab4-2-idx1)
78+
= some-key-value-1
79+
DISPLAY 'Ok'
80+
END-SEARCH
81+
*KO must use equality
82+
SEARCH ALL tab4-2
83+
WHEN tab4-2-key-asc (tab4-idx1 tab4-1-idx1 tab4-2-idx1)
84+
> some-key-value-1
85+
DISPLAY 'Ok'
86+
END-SEARCH
87+
*KO must use AND
88+
SEARCH ALL tab4-2
89+
WHEN tab4-2-key-asc (tab4-idx1 tab4-1-idx1 tab4-2-idx1)
90+
= some-key-value-1
91+
OR
92+
tab4-2-key-desc (tab4-idx1 tab4-1-idx1 tab4-2-idx1)
93+
= some-key-value-2
94+
DISPLAY 'Ok'
95+
END-SEARCH
96+
*KO not a table item comparison
97+
SEARCH ALL tab4-2
98+
WHEN tab4-2-key-asc (tab4-idx1 tab4-1-idx1 tab4-2-idx1)
99+
IS NUMERIC
100+
DISPLAY 'Ok'
101+
END-SEARCH
102+
*KO must use first index
103+
SEARCH ALL tab4-2
104+
WHEN tab4-2-key-asc (tab4-idx1 tab4-1-idx2 tab4-2-idx3)
105+
= some-key-value-1
106+
DISPLAY 'Ok'
107+
END-SEARCH
108+
*KO must use proper keys
109+
SEARCH ALL tab4-2
110+
WHEN tab5-2-key (tab4-idx1 tab4-1-idx1 tab4-2-idx1)
111+
= some-key-value-1
112+
DISPLAY 'Ok'
113+
END-SEARCH
114+
*KO key must be on left side
115+
SEARCH ALL tab4-2
116+
WHEN some-key-value-1
117+
= tab4-2-key-asc (tab4-idx1 tab4-1-idx1 tab4-2-idx1)
118+
DISPLAY 'Ok'
119+
END-SEARCH
120+
*OK
121+
SEARCH ALL tab4-2
122+
WHEN tab4-2-key-asc (tab4-idx1 tab4-1-idx1 tab4-2-idx1)
123+
= some-key-value-1
124+
DISPLAY 'Ok'
125+
END-SEARCH
126+
GOBACK
127+
.
128+
END PROGRAM Pgm.

‎TypeCobol.Test/Parser/Programs/Cobol85/SearchAllWhen2.rdzMix.txt‎

Lines changed: 143 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,143 @@
1+
IDENTIFICATION DIVISION.
2+
PROGRAM-ID. Pgm.
3+
DATA DIVISION.
4+
WORKING-STORAGE SECTION.
5+
6+
01 NotATable PIC X(20).
7+
8+
01 TableWithoutKey.
9+
05 tab1 OCCURS 20.
10+
10 tab1-item PIC X.
11+
12+
01 TableWithoutIndex.
13+
05 tab2 OCCURS 20
14+
ASCENDING KEY IS tab2-key.
15+
10 tab2-key PIC 99.
16+
10 tab2-item PIC XX.
17+
18+
01 MultiDim1.
19+
05 tab3 OCCURS 10.
20+
10 tab3-1 OCCURS 10
21+
ASCENDING KEY IS tab3-1-key
22+
INDEXED BY tab3-1-idx.
23+
15 tab3-1-key PIC 99.
24+
15 tab3-1-item PIC XX.
25+
26+
01 test-value PIC XX.
27+
01 some-value PIC XX.
28+
29+
01 MultiDim2.
30+
05 tab4 OCCURS 10
31+
INDEXED BY tab4-idx1 tab4-idx2 tab4-idx3.
32+
10 tab4-1 OCCURS 10
33+
INDEXED BY tab4-1-idx1 tab4-1-idx2 tab4-1-idx3.
34+
15 tab4-2 OCCURS 10
35+
ASCENDING KEY IS tab4-2-key-asc
36+
DESCENDING KEY IS tab4-2-key-desc
37+
INDEXED BY tab4-2-idx1 tab4-2-idx2
38+
tab4-2-idx3.
39+
20 tab4-2-key-asc PIC 99.
40+
20 tab4-2-key-desc PIC 99.
41+
20 tab4-2-item PIC XX.
42+
43+
01 some-key-value-1 PIC 99.
44+
01 some-key-value-2 PIC 99.
45+
46+
01 MultiDim3.
47+
05 tab5 OCCURS 10.
48+
10 tab5-1 OCCURS 10.
49+
15 tab5-2 OCCURS 10
50+
ASCENDING KEY IS tab5-2-key.
51+
20 tab5-2-key PIC 99.
52+
20 tab5-2-item PIC XX.
53+
54+
PROCEDURE DIVISION.
55+
*KO search on something that is not a table
56+
Line 56[12,31] <27, Error, Syntax> - Syntax error : Cannot SEARCH in 'NotATable', data item is not a table.
57+
SEARCH ALL NotATable
58+
WHEN test-value = some-value
59+
DISPLAY 'Ok'
60+
END-SEARCH
61+
*KO binary search on a table without key
62+
Line 61[12,26] <27, Error, Syntax> - Syntax error : Cannot use binary SEARCH on 'tab1' because it has no KEY.
63+
Line 61[12,26] <27, Error, Syntax> - Syntax error : Cannot use binary SEARCH on 'tab1' because it is not indexed.
64+
SEARCH ALL tab1
65+
Line 62[15,42] <27, Error, Syntax> - Syntax error : Left side operand of a WHEN condition must use first index of the table and at least one of declared keys.
66+
WHEN test-value = some-value
67+
DISPLAY 'Ok'
68+
END-SEARCH
69+
*KO binary search on a table without index
70+
Line 66[12,26] <27, Error, Syntax> - Syntax error : Cannot use binary SEARCH on 'tab2' because it is not indexed.
71+
SEARCH ALL tab2
72+
Line 67[15,42] <27, Error, Syntax> - Syntax error : Left side operand of a WHEN condition must use first index of the table and at least one of declared keys.
73+
WHEN test-value = some-value
74+
DISPLAY 'Ok'
75+
END-SEARCH
76+
*KO binary search on a table with parent table without index
77+
Line 71[12,28] <27, Error, Syntax> - Syntax error : Cannot use binary SEARCH on 'tab3-1' because parent table 'tab3' is not indexed.
78+
SEARCH ALL tab3-1
79+
Line 72[15,42] <27, Error, Syntax> - Syntax error : Left side operand of a WHEN condition must use first index of the table and at least one of declared keys.
80+
WHEN test-value = some-value
81+
DISPLAY 'Ok'
82+
END-SEARCH
83+
*KO all keys defined before any referenced key must be used
84+
SEARCH ALL tab4-2
85+
Line 77[15,37] <27, Error, Syntax> - Syntax error : All the table keys that precede a referenced key must be used.
86+
WHEN tab4-2-key-desc (tab4-idx1 tab4-1-idx1 tab4-2-idx1)
87+
= some-key-value-1
88+
DISPLAY 'Ok'
89+
END-SEARCH
90+
*KO must use equality
91+
SEARCH ALL tab4-2
92+
Line 83[15,37] <27, Error, Syntax> - Syntax error : Invalid relational operator in WHEN SEARCH condition, EqualTo operator expected.
93+
WHEN tab4-2-key-asc (tab4-idx1 tab4-1-idx1 tab4-2-idx1)
94+
> some-key-value-1
95+
DISPLAY 'Ok'
96+
END-SEARCH
97+
*KO must use AND
98+
SEARCH ALL tab4-2
99+
Line 89[15,37] <27, Error, Syntax> - Syntax error : Invalid logical operator in WHEN SEARCH condition, AND operator expected.
100+
WHEN tab4-2-key-asc (tab4-idx1 tab4-1-idx1 tab4-2-idx1)
101+
= some-key-value-1
102+
OR
103+
tab4-2-key-desc (tab4-idx1 tab4-1-idx1 tab4-2-idx1)
104+
= some-key-value-2
105+
DISPLAY 'Ok'
106+
END-SEARCH
107+
*KO not a table item comparison
108+
SEARCH ALL tab4-2
109+
Line 98[15,29] <27, Error, Syntax> - Syntax error : Invalid condition in WHEN SEARCH, only condition-names and key to value comparison are allowed.
110+
WHEN tab4-2-key-asc (tab4-idx1 tab4-1-idx1 tab4-2-idx1)
111+
IS NUMERIC
112+
DISPLAY 'Ok'
113+
END-SEARCH
114+
*KO must use first index
115+
SEARCH ALL tab4-2
116+
Line 104[15,37] <27, Error, Syntax> - Syntax error : When subscripting, only first index declared for the table is allowed.
117+
WHEN tab4-2-key-asc (tab4-idx1 tab4-1-idx2 tab4-2-idx3)
118+
= some-key-value-1
119+
DISPLAY 'Ok'
120+
END-SEARCH
121+
*KO must use proper keys
122+
SEARCH ALL tab4-2
123+
Line 110[15,37] <27, Error, Syntax> - Syntax error : 'tab5-2-key' is not a sorting key of table 'tab4-2'.
124+
WHEN tab5-2-key (tab4-idx1 tab4-1-idx1 tab4-2-idx1)
125+
= some-key-value-1
126+
DISPLAY 'Ok'
127+
END-SEARCH
128+
*KO key must be on left side
129+
SEARCH ALL tab4-2
130+
Line 116[15,71] <27, Error, Syntax> - Syntax error : Left side operand of a WHEN condition must use first index of the table and at least one of declared keys.
131+
WHEN some-key-value-1
132+
= tab4-2-key-asc (tab4-idx1 tab4-1-idx1 tab4-2-idx1)
133+
DISPLAY 'Ok'
134+
END-SEARCH
135+
*OK
136+
SEARCH ALL tab4-2
137+
WHEN tab4-2-key-asc (tab4-idx1 tab4-1-idx1 tab4-2-idx1)
138+
= some-key-value-1
139+
DISPLAY 'Ok'
140+
END-SEARCH
141+
GOBACK
142+
.
143+
END PROGRAM Pgm.

0 commit comments

Comments
 (0)