Fix/zcobol search

rt/bash/runcbltests

@@ -48,6 +48,8 @@ export OUTFILE=
 bash/cblclg zcobol/tests/TESTSIX1 $1 $2 $3 $4 $5 $6 $7 $8 $9
 bash/cblclg zcobol/tests/TESTSIX2 $1 $2 $3 $4 $5 $6 $7 $8 $9
 bash/cblclg zcobol/tests/TESTSRCH $1 $2 $3 $4 $5 $6 $7 $8 $9
+bash/cblclg zcobol/tests/TSRCHEND $1 $2 $3 $4 $5 $6 $7 $8 $9
+bash/cblclg zcobol/tests/TSRCHOP  $1 $2 $3 $4 $5 $6 $7 $8 $9
 bash/cblclg zcobol/tests/TESTSUB1 $1 $2 $3 $4 $5 $6 $7 $8 $9
 bash/cblclg zcobol/tests/TESTSUB2 $1 $2 $3 $4 $5 $6 $7 $8 $9
 bash/cblclg zcobol/tests/TESTTRC1 $1 $2 $3 $4 $5 $6 $7 $8 $9 TRUNC

rt/bat/RUNCBLTESTS.BAT

@@ -54,6 +54,8 @@ set OUTFILE=
 call bat\CBLCLG %z_TraceMode% zcobol\tests\TESTSIX1 %1 %2 %3 %4 %5 %6 %7 %8 %9 || goto error
 call bat\CBLCLG %z_TraceMode% zcobol\tests\TESTSIX2 %1 %2 %3 %4 %5 %6 %7 %8 %9 || goto error
 call bat\CBLCLG %z_TraceMode% zcobol\tests\TESTSRCH %1 %2 %3 %4 %5 %6 %7 %8 %9 || goto error
+call bat\CBLCLG %z_TraceMode% zcobol\tests\TSRCHEND %1 %2 %3 %4 %5 %6 %7 %8 %9 || goto error
+call bat\CBLCLG %z_TraceMode% zcobol\tests\TSRCHOP  %1 %2 %3 %4 %5 %6 %7 %8 %9 || goto error
 call bat\CBLCLG %z_TraceMode% zcobol\tests\TESTSUB1 %1 %2 %3 %4 %5 %6 %7 %8 %9 || goto error
 call bat\CBLCLG %z_TraceMode% zcobol\tests\TESTSUB2 %1 %2 %3 %4 %5 %6 %7 %8 %9 || goto error
 call bat\CBLCLG %z_TraceMode% zcobol\tests\TESTTRC1 %1 %2 %3 %4 %5 %6 %7 %8 %9 TRUNC       || goto error

z390test/src/test/groovy/org/z390/test/RunCblTests.groovy

@@ -22,7 +22,7 @@ class RunCblTests extends z390Test{
                 'TESTCMP1', 'TESTCMP2', 'TESTCMP3', 'TESTCMP4', 'TESTCMP5', 'TESTCMP6', 'TESTCPY1', 'TESTCPY2', 'TESTDFP1', 'TESTDIV1', 'TESTDIV2', 'TESTDSP1',
                 'TESTGO1',  'TESTHFP1', 'TESTISP1', 'TESTPIC1', 'TESTPM1',  'TESTPM2',  'TESTSIX1', 'TESTSIX2', 'TESTSRCH', 'TESTSUB1', 'TESTSUB2', 'TESTTRC2',
                 'TESTWS1',  'TESTFUN1', 'TESTINT1', 'TESTMPY1', 'TESTMPY2', 'TESTRMD1', 'TESTSTR1', 'TESTSTR2', 'TESTSTR3', 'TSUNSTR',
-                'YOUZPI1',  'YOUZPI2'
+                'YOUZPI1',  'YOUZPI2',  'TSRCHEND', 'TSRCHOP'
         ]
         modules.each {
             module -> tests.add(

zcobol/cpy/ZC_WS.CPY

@@ -257,7 +257,7 @@
          GBLA &IE_LVL               CURRENT LEVEL FOR IF OR EVALUATE
          GBLA &IE_TYPE(100)     1=IF, 2=EVALUATE, 3=END_READ 4=PM
 .*                                  11=ADD,12=SUB,13=MPY,14=DIV
-.*                                  15=SEARCH
+.*                                  15=RETURN,16=SEARCH
          GBLA &IE_TCNT(100)     IE TYPE  COUNT                  
          GBLA &IE_NOT(100)      NOT ON SIZE ERROR USED AT LEVEL
          GBLA &IE_BCNT(100)     IE BLOCK COUNT WITHIN TYPE     
@@ -267,7 +267,7 @@
          GBLA &IE_WHEN(100)     CURRENT EVAL WHEN LABEL #
          GBLC &IE_PM_LAB(100)   CURRENT PM STMT LOOP LABEL
 .*
-.* SEARCH STATEMENT SUPPORT (IE_TYPE=15)
+.* SEARCH STATEMENT SUPPORT (IE_TYPE=16)
 .* These variables store context for SEARCH/WHEN/END-SEARCH processing
 .* Indexed by IE_LVL to support nested SEARCH statements
 .*

zcobol/mac/END_SEARCH.MAC

@@ -32,7 +32,7 @@
 .*   5. END label (exit point for completed search)
 .*
 .* Uses IE block tracking to match with corresponding SEARCH:
-.*   IE_TYPE 15 = SEARCH (see ZC_WS.CPY:254)
+.*   IE_TYPE 16 = SEARCH (see ZC_WS.CPY)
 .*********************************************************************
          END_SEARCH
          COPY  ZC_WS
@@ -43,7 +43,7 @@
                MNOTE 8,'END-SEARCH WITHOUT MATCHING SEARCH'
                MEXIT
          AEND
-         AIF   (&IE_TYPE(&IE_LVL) NE 15)
+         AIF   (&IE_TYPE(&IE_LVL) NE 16)
                MNOTE 8,'END-SEARCH NOT IN A SEARCH BLOCK'
                MEXIT
          AEND

zcobol/mac/PERIOD.MAC

@@ -24,7 +24,7 @@
 .* 10/06/08 ZSTRMAC
 .* 07/14/09 RPI 1064 drop b2's at period if used
 .* 02/21/12 RPI 1182 move base reset to GEN_PERFROM and GEN_LABEL
-.* 2025/12 ZH: Add SEARCH support (IE_TYPE=15)
+.* 2025/12 ZH: Add SEARCH support (IE_TYPE=16; 15=RETURN)
 .*********************************************************************
          PERIOD
          COPY  ZC_WS
@@ -47,6 +47,8 @@
                      END_DIVIDE
                AELSEIF (&IE_TYPE(&IE_LVL) EQ 15)
                      END_RETURN
+               AELSEIF (&IE_TYPE(&IE_LVL) EQ 16)
+                     END_SEARCH
                AELSE
                      MNOTE 8,'PERIOD UNKNOWN LEVEL TYPE - &IE_TYPE(&IE_X
                LVL)'

zcobol/mac/SEARCH.MAC

@@ -33,7 +33,7 @@
 .* value and increments until a WHEN condition matches or end-of-table.
 .*
 .* Uses IE (If/Evaluate) block tracking system - see ZC_WS.CPY:
-.*   IE_TYPE 15 = SEARCH (added to existing types 1-14)
+.*   IE_TYPE 16 = SEARCH (15 = RETURN; added to existing types 1-14)
 .*   IE_SRC_* variables store SEARCH-specific context for END_SEARCH
 .*
 .* Generated label structure:
@@ -129,7 +129,7 @@
 .* This allows nested SEARCH/IF/EVALUATE and proper END_SEARCH matching
 .*
 .* IE_LVL   - Current nesting depth (incremented for each block)
-.* IE_TYPE  - Block type identifier (15 = SEARCH, see ZC_WS.CPY:254)
+.* IE_TYPE  - Block type identifier (16 = SEARCH, see ZC_WS.CPY)
 .* IE_TCNT  - Label counter for unique label generation
 .*
 .* IE_SRC_* variables hold SEARCH context for WHEN and END_SEARCH:
@@ -142,7 +142,7 @@
 .*
          :&SRC_LAB SETA &SRC_LAB+1
          :&IE_LVL SETA &IE_LVL+1
-         :&IE_TYPE(&IE_LVL) SETA 15
+         :&IE_TYPE(&IE_LVL) SETA 16
          :&IE_TCNT(&IE_LVL) SETA &SRC_LAB
          :&IE_SRC_TBL(&IE_LVL) SETC '&TBL_NAME'
          :&IE_SRC_IDX(&IE_LVL) SETC '&IDX_NAME'

zcobol/mac/WHEN.MAC

@@ -32,7 +32,7 @@
                MNOTE 8,'WHEN MISSING EVALUATE OR SEARCH'
                MEXIT
          AEND
-         AIF   (&IE_TYPE(&IE_LVL) EQ 15)
+         AIF   (&IE_TYPE(&IE_LVL) EQ 16)
 .*
 .* SEARCH WHEN - Format: WHEN field = value
 .*
@@ -68,7 +68,7 @@
 .*
 .*********************************************************************
 .* SEARCH WHEN HANDLER
-.* Called when WHEN appears inside a SEARCH block (IE_TYPE=15)
+.* Called when WHEN appears inside a SEARCH block (IE_TYPE=16)
 .*
 .* Syntax: WHEN field1 operator field2
 .* Example: WHEN TABLE-KEY(IDX) = SEARCH-ARG
@@ -123,11 +123,68 @@
                MEXIT
          AEND
 .*
-.* Get the comparison operator (=, <, >, etc.)
-.* PARM_IX was advanced by GET_PARM_FIELD, now points to operator
+.* Parse the COBOL relational operator, tolerating the reserved
+.* noise words IS, THAN and TO and the word forms EQUAL, GREATER,
+.* LESS and NOT.  On entry PARM_IX points at the first token after
+.* field1; on exit it points at the first token of the 2nd operand.
 .*
+.*   &SRC_REL - canonical relation: EQ GT LT GE LE
+.*   &SRC_NEG - set when the relation is negated with NOT
+.*
+         AIF   ('&SYSLIST(&PARM_IX)' EQ 'IS')   skip optional IS
+               :&PARM_IX SETA &PARM_IX+1
+         AEND
+         :&SRC_NEG SETB 0
+         AIF   ('&SYSLIST(&PARM_IX)' EQ 'NOT')  optional NOT
+               :&SRC_NEG SETB 1
+               :&PARM_IX SETA &PARM_IX+1
+         AEND
          :&OPER SETC '&SYSLIST(&PARM_IX)'
          :&PARM_IX SETA &PARM_IX+1
+         :&SRC_REL SETC ''
+         AIF ('&OPER' EQ '=' OR '&OPER' EQ 'EQUAL')
+               :&SRC_REL SETC 'EQ'
+               AIF ('&SYSLIST(&PARM_IX)' EQ 'TO')   skip noise TO
+                   :&PARM_IX SETA &PARM_IX+1
+               AEND
+         AELSEIF ('&OPER' EQ '>=' OR '&OPER' EQ 'GE')
+               :&SRC_REL SETC 'GE'
+         AELSEIF ('&OPER' EQ '<=' OR '&OPER' EQ 'LE')
+               :&SRC_REL SETC 'LE'
+         AELSEIF ('&OPER' EQ '>' OR '&OPER' EQ 'GREATER')
+               :&SRC_REL SETC 'GT'
+               AIF ('&SYSLIST(&PARM_IX)' EQ 'THAN')   skip noise THAN
+                   :&PARM_IX SETA &PARM_IX+1
+               AEND
+               AIF ('&SYSLIST(&PARM_IX)' EQ 'OR')   GREATER OR EQUAL
+                   :&SRC_REL SETC 'GE'
+                   :&PARM_IX SETA &PARM_IX+1
+                   AIF ('&SYSLIST(&PARM_IX)' EQ 'EQUAL')
+                       :&PARM_IX SETA &PARM_IX+1
+                   AEND
+                   AIF ('&SYSLIST(&PARM_IX)' EQ 'TO')
+                       :&PARM_IX SETA &PARM_IX+1
+                   AEND
+               AEND
+         AELSEIF ('&OPER' EQ '<' OR '&OPER' EQ 'LESS')
+               :&SRC_REL SETC 'LT'
+               AIF ('&SYSLIST(&PARM_IX)' EQ 'THAN')   skip noise THAN
+                   :&PARM_IX SETA &PARM_IX+1
+               AEND
+               AIF ('&SYSLIST(&PARM_IX)' EQ 'OR')   LESS OR EQUAL
+                   :&SRC_REL SETC 'LE'
+                   :&PARM_IX SETA &PARM_IX+1
+                   AIF ('&SYSLIST(&PARM_IX)' EQ 'EQUAL')
+                       :&PARM_IX SETA &PARM_IX+1
+                   AEND
+                   AIF ('&SYSLIST(&PARM_IX)' EQ 'TO')
+                       :&PARM_IX SETA &PARM_IX+1
+                   AEND
+               AEND
+         AELSE
+               MNOTE 8,'SEARCH WHEN INVALID OPERATOR - &OPER'
+               MEXIT
+         AEND
 .*
 .* Parse second operand (right side of comparison)
 .* Can be a field name or a literal value
@@ -138,31 +195,36 @@
          :&SRC_FLD2 SETC '&FIELD_NAME'
          :&SRC_FLD2_IX SETA &FIELD_IX
 .*
-.* Map COBOL operator to condition code for FALSE branch
-.*
-.* We branch to INCR when condition is FALSE (try next element)
-.* So we need the INVERSE condition code:
-.*   COBOL "="  -> branch on NOT EQUAL (ZC_NE)
-.*   COBOL "<"  -> branch on GREATER OR EQUAL (ZC_GE)
-.*   COBOL ">"  -> branch on LESS OR EQUAL (ZC_LE)
-.*   etc.
+.* Map relation (and optional NOT) to the condition-code mask used
+.* to branch to INCR when the WHEN condition is FALSE.  When not
+.* negated we branch on the inverse relation; when negated (NOT) we
+.* branch on the relation itself.
 .*
          :&SRC_CCT SETC ''
-         AIF ('&OPER' EQ '=' OR '&OPER' EQ 'EQUAL')
-               :&SRC_CCT SETC 'ZC_NE'
-         AELSEIF ('&OPER' EQ '<' OR '&OPER' EQ 'LESS')
-               :&SRC_CCT SETC 'ZC_GE'
-         AELSEIF ('&OPER' EQ '>' OR '&OPER' EQ 'GREATER')
-               :&SRC_CCT SETC 'ZC_LE'
-         AELSEIF ('&OPER' EQ '<=' OR '&OPER' EQ 'LE')
-               :&SRC_CCT SETC 'ZC_H'
-         AELSEIF ('&OPER' EQ '>=' OR '&OPER' EQ 'GE')
-               :&SRC_CCT SETC 'ZC_L'
-         AELSEIF ('&OPER' EQ 'NOT')
-               :&SRC_CCT SETC 'ZC_EQ'
+         AIF (NOT &SRC_NEG)
+               AIF   ('&SRC_REL' EQ 'EQ')
+                     :&SRC_CCT SETC 'ZC_NE'
+               AELSEIF ('&SRC_REL' EQ 'LT')
+                     :&SRC_CCT SETC 'ZC_GE'
+               AELSEIF ('&SRC_REL' EQ 'GT')
+                     :&SRC_CCT SETC 'ZC_LE'
+               AELSEIF ('&SRC_REL' EQ 'LE')
+                     :&SRC_CCT SETC 'ZC_H'
+               AELSEIF ('&SRC_REL' EQ 'GE')
+                     :&SRC_CCT SETC 'ZC_L'
+               AEND
          AELSE
-               MNOTE 8,'SEARCH WHEN INVALID OPERATOR - &OPER'
-               MEXIT
+               AIF   ('&SRC_REL' EQ 'EQ')
+                     :&SRC_CCT SETC 'ZC_EQ'
+               AELSEIF ('&SRC_REL' EQ 'LT')
+                     :&SRC_CCT SETC 'ZC_L'
+               AELSEIF ('&SRC_REL' EQ 'GT')
+                     :&SRC_CCT SETC 'ZC_H'
+               AELSEIF ('&SRC_REL' EQ 'LE')
+                     :&SRC_CCT SETC 'ZC_LE'
+               AELSEIF ('&SRC_REL' EQ 'GE')
+                     :&SRC_CCT SETC 'ZC_GE'
+               AEND
          AEND
 .*
 .* Generate the actual field comparison code

zcobol/tests/TSRCHEND.CBL

@@ -0,0 +1,74 @@
+       IDENTIFICATION DIVISION.
+       PROGRAM-ID.  TSRCHEND.
+      ******************************************************************
+      * Repro for issue #825 - SEARCH not generating AT END label.
+      * Mirrors NIST NC401M: SEARCH with AT END plus a WHEN condition
+      * written with COBOL relational noise words (IS EQUAL TO).
+      *
+      * Expected (after fix): translates, assembles, runs, AT END path
+      * taken for a missing key, WHEN path taken for a present key.
+      ******************************************************************
+       ENVIRONMENT DIVISION.
+       DATA DIVISION.
+       WORKING-STORAGE SECTION.
+       01  EMPLOYEE-TABLE.
+           05  EMP-ENTRY OCCURS 5 TIMES INDEXED BY EMP-IX.
+               10  EMP-ID    PIC 9(3).
+               10  EMP-NAME  PIC X(10).
+       01  PASS-COUNT     PIC 9(2)    VALUE 0.
+       01  FAIL-COUNT     PIC 9(2)    VALUE 0.
+       01  WS-FOUND       PIC 9       VALUE 0.
+       01  SEARCH-ID      PIC 9(3)    VALUE 0.
+
+       PROCEDURE DIVISION.
+       MAIN-PARA.
+           DISPLAY 'TSRCHEND - SEARCH AT END NOISE-WORD TEST'.
+           MOVE 101 TO EMP-ID(1).
+           MOVE 102 TO EMP-ID(2).
+           MOVE 103 TO EMP-ID(3).
+           MOVE 104 TO EMP-ID(4).
+           MOVE 105 TO EMP-ID(5).
+      *
+      *    Test 1: present key, WHEN ... IS EQUAL TO ...
+      *
+           MOVE 0 TO WS-FOUND.
+           MOVE 103 TO SEARCH-ID.
+           SET EMP-IX TO 1.
+           SEARCH EMP-ENTRY
+               AT END
+                   MOVE 9 TO WS-FOUND
+               WHEN EMP-ID(EMP-IX) IS EQUAL TO SEARCH-ID
+                   MOVE 1 TO WS-FOUND
+           END-SEARCH.
+           IF WS-FOUND = 1
+               DISPLAY 'TEST 1: PASS - FOUND ID 103'
+               ADD 1 TO PASS-COUNT
+           ELSE
+               DISPLAY 'TEST 1: FAIL - DID NOT FIND ID 103'
+               ADD 1 TO FAIL-COUNT.
+      *
+      *    Test 2: missing key, AT END must fire
+      *
+           MOVE 0 TO WS-FOUND.
+           MOVE 999 TO SEARCH-ID.
+           SET EMP-IX TO 1.
+           SEARCH EMP-ENTRY
+               AT END
+                   MOVE 2 TO WS-FOUND
+               WHEN EMP-ID(EMP-IX) IS EQUAL TO SEARCH-ID
+                   MOVE 1 TO WS-FOUND
+           END-SEARCH.
+           IF WS-FOUND = 2
+               DISPLAY 'TEST 2: PASS - AT END EXECUTED FOR ID 999'
+               ADD 1 TO PASS-COUNT
+           ELSE
+               DISPLAY 'TEST 2: FAIL - AT END NOT EXECUTED'
+               ADD 1 TO FAIL-COUNT.
+           DISPLAY 'TSRCHEND - COMPLETED'.
+           DISPLAY 'PASSED: ' PASS-COUNT ' FAILED: ' FAIL-COUNT.
+           IF FAIL-COUNT = 0
+               DISPLAY 'TSRCHEND - ALL TESTS PASSED'
+           ELSE
+               DISPLAY 'TSRCHEND - SOME TESTS FAILED'
+               MOVE 8 TO RETURN-CODE.
+           STOP RUN.