diff --git a/docs/language_status/cobolrt_rules.json b/docs/language_status/cobolrt_rules.json index 388ce21769..8461505e55 100644 --- a/docs/language_status/cobolrt_rules.json +++ b/docs/language_status/cobolrt_rules.json @@ -812,6 +812,24 @@ "status": "REFUSED", "calibration": "uncalibrated" }, + { + "id": "RT-CBL-COUNTER-NONDIGIT-REFUSED", + "family": "CBL", + "title": "A STRING / UNSTRING POINTER, an UNSTRING TALLYING IN item and an INSPECT TALLYING counter are read before they store: a zoned one holding a non-digit is refused by name", + "methods": [ + "counterNum" + ], + "ibm": null, + "ibm_note": "IBM documents no result (ZONEDATA(PFD) assumes valid zone bits); the same ground as the receiver of ADD", + "options": [ + "ZONEDATA" + ], + "register": [ + "C11" + ], + "status": "REFUSED", + "calibration": "uncalibrated" + }, { "id": "RT-CBL-COMPARE-NONDIGIT", "family": "CBL", @@ -1415,7 +1433,8 @@ "refuse", "pScaled", "refuseP", - "refuseReceiver" + "refuseReceiver", + "refuseCounter" ], "site": "refuse", "ibm": null, diff --git a/docs/language_status/register/C11.md b/docs/language_status/register/C11.md index 287a1455cc..27b2342f88 100644 --- a/docs/language_status/register/C11.md +++ b/docs/language_status/register/C11.md @@ -84,6 +84,16 @@ reached: "yes (COMEN01C option `1!`; GenApp LGTESTP4's add)" TRAN-ID`) can see a non-digit; CBSA 4, GenApp 23, the others 0 cannot. Per verb (#4692): ADD / SUBTRACT / MULTIPLY / DIVIDE refuse a dirty receiver (above); MOVE and GIVING overwrite it, so the receiver is not read (modelled, measured); COMPUTE reads it as an operand (modelled). +- **A non-digit in a POINTER / TALLYING item (#4692) -- REFUSED by name.** The same read-before-store as the receiver of + ADD: `INSPECT ... TALLYING ctr` and `UNSTRING ... TALLYING IN ctr` add to the counter's current value, and + `STRING ... WITH POINTER p` / `UNSTRING ... WITH POINTER p` read where to start. A zoned item holding a non-digit + there (a counter cleared by `MOVE SPACES`) is refused at run time (`Cobol.counterNum`: "a STRING / UNSTRING pointer + or tallying counter that is a zoned item holding a non-digit is not modelled"), on IBM's ground above (no result + documented); a digit-only one counts as ever. Tested over the five receiver shapes x INSPECT ALL / CHARACTERS, + UNSTRING TALLYING / POINTER, STRING POINTER, and the digit-only start of each (`test_det_nondigit_zoned.py`). A plain + item (no REDEFINES) cleared to spaces and then ADDed to is refused too (the lifted-item path goes through the same + `receiverNum`). Not covered, no burned program reads one: ADD CORRESPONDING, `PERFORM VARYING` / `SET ... UP BY` + steps of a dirty index. - **A zoned item with a P position holding a non-digit, as a sender (#4685, #4692) -- REFUSED by name.** Measured against cobc 3.1.2 (`-std=ibm -fsign=EBCDIC`, TRUNC STD and BIN): a left-P item (`PIC VPP99`) MOVEd to a binary item makes the program hang (the 14-operation probe never finished; `timeout` killed it), and a right-P one (`PIC 99PP`) is diff --git a/gitgalaxy/tools/cobol_to_java/det/cobolrt/Cobol.java b/gitgalaxy/tools/cobol_to_java/det/cobolrt/Cobol.java index d7e0bed3c9..25fdb8b7cf 100644 --- a/gitgalaxy/tools/cobol_to_java/det/cobolrt/Cobol.java +++ b/gitgalaxy/tools/cobol_to_java/det/cobolrt/Cobol.java @@ -823,6 +823,17 @@ public static BigDecimal receiverNum(Field f, Charset cs) { return num(f, cs); } + /** The current value of a STRING / UNSTRING POINTER, an UNSTRING TALLYING IN or an INSPECT TALLYING counter (#4692, + * register C11): the statement reads the item before it stores, as ADD does its receiver. A zoned item holding a + * non-digit is refused by name for the same reason as {@link #receiverNum}; a digit-only one is read as ever. */ + // [rule RT-CBL-COUNTER-NONDIGIT-REFUSED] + public static BigDecimal counterNum(Field f, Charset cs) { + if (f.kind == Field.Kind.NUMERIC_DISPLAY && Zoned.get(f, cs).dirty) { + throw Zoned.refuseCounter(); + } + return num(f, cs); + } + /** A numeric item's value in a comparison (#4662): a zoned item holding a non-digit as the oracle compares it. */ // [rule RT-CBL-COMPARE-NONDIGIT] public static BigDecimal cmpNum(Field f, Charset cs) { @@ -1319,7 +1330,7 @@ private static boolean matches(byte[] hay, int at, byte[] pat) { public static boolean string(Field into, Field pointer, Charset cs, StringPart... parts) { int off = 0; if (pointer != null) { - BigDecimal p = num(pointer, cs); + BigDecimal p = counterNum(pointer, cs); if (p.compareTo(BigDecimal.ONE) < 0 || p.compareTo(BigDecimal.valueOf(into.len)) > 0) return true; off = p.intValue() - 1; } @@ -1403,7 +1414,7 @@ public static boolean unstring(Field src, Field pointer, Field tallying, List 0) return true; off = p.intValue() - 1; } @@ -1440,7 +1451,7 @@ public static boolean unstring(Field src, Field pointer, Field tallying, List 0) return true; off = p.intValue() - 1; } @@ -1403,7 +1414,7 @@ public static boolean unstring(Field src, Field pointer, Field tallying, List 0) return true; off = p.intValue() - 1; } @@ -1440,7 +1451,7 @@ public static boolean unstring(Field src, Field pointer, Field tallying, List str: + pic, ln = KINDS[kind] + lines = [" IDENTIFICATION DIVISION.", " PROGRAM-ID. NDB.", " DATA DIVISION.", + " WORKING-STORAGE SECTION.", f" 01 R PIC X({ln}).", f" 01 V REDEFINES R {pic}.", + " 01 S PIC X(8) VALUE 'A,AA,A '.", " 01 D1 PIC X(8).", " 01 D2 PIC X(8).", + " PROCEDURE DIVISION.", f" MOVE X'{data.hex().upper()}' TO R", f" {op}", + " DISPLAY 'R=' R", " GOBACK.", ""] # fmt: skip + return "\n".join(lines) + + +@pytest.mark.skipif(_java() is None, reason="needs a JDK 17 (JAVA_HOME / JDK_17)") +@pytest.mark.parametrize("op", list(COUNTER_OPS)) +@pytest.mark.parametrize("kind", list(KINDS)) +def test_a_non_digit_counter_or_pointer_is_refused_by_name(kind, op, tmp_path): + pytest.importorskip("tree_sitter_language_pack") + data = _rcases(kind, True)[1] # one letter-bearing case per shape (the first is spaces / a bad sign) + run = _det(_cprogram(kind, COUNTER_OPS[op][0], data), tmp_path, "STD") + assert run.returncode != 0 and "register C11" in run.stderr, (data, run.stderr) + assert "pointer or tallying counter that is a zoned item holding a non-digit is not modelled" in run.stderr + + +@pytest.mark.skipif(_java() is None, reason="needs a JDK 17 (JAVA_HOME / JDK_17)") +@pytest.mark.parametrize("op", list(COUNTER_OPS)) +def test_a_digit_only_counter_or_pointer_counts_as_ever(op, tmp_path): + pytest.importorskip("tree_sitter_language_pack") + start = b"0001" if op.endswith("PTR") else b"0000" + run = _det(_cprogram("U", COUNTER_OPS[op][0], start), tmp_path, "STD") + assert run.returncode == 0, run.stderr + want = int(COUNTER_OPS[op][1]) + assert f"R={want:04d}" in run.stdout.replace("\r", ""), (run.stdout, want) + + +@pytest.mark.skipif(_java() is None, reason="needs a JDK 17 (JAVA_HOME / JDK_17)") +@pytest.mark.parametrize("op", ["ADD 1 TO V", "ADD W TO V", "SUBTRACT 1 FROM V", "MULTIPLY 2 BY V"]) +def test_a_plain_item_cleared_to_spaces_is_refused_as_a_receiver(op, tmp_path): + """The item the translator may lift (no REDEFINES, named plainly): `MOVE SPACES TO V` then the statement.""" + pytest.importorskip("tree_sitter_language_pack") + src = "\n".join([" IDENTIFICATION DIVISION.", " PROGRAM-ID. NDB.", " DATA DIVISION.", + " WORKING-STORAGE SECTION.", " 01 V PIC 9(4).", " 01 W PIC 9(4) VALUE 5.", + " PROCEDURE DIVISION.", " MOVE SPACES TO V", f" {op}", + " DISPLAY V", " GOBACK.", ""]) # fmt: skip + run = _det(src, tmp_path, "STD") + assert run.returncode != 0 and "receiver is a zoned item holding a non-digit is not modelled" in run.stderr + + # --------------------------------------------------------------------------------------------------------------- # #4692 / #4685: a zoned SENDER with a P position holding a non-digit. cobc 3.1.2 (measured) hangs on `MOVE` of a left-P # one (VPP99) to a binary item and computes a right-P one (99PP) by no explainable rule (`ADD S TO DS` of two spaces