det: JSON PARSE takes COMP / COMP-3 / COMP-5 numeric receivers (Part of #7524, #7709)

docs/language_status/cobolrt_rules.json

@@ -620,7 +620,7 @@
   {
    "id": "RT-CBL-JSON-PARSE",
    "family": "CBL",
-   "title": "JSON PARSE INTO a group of DISPLAY items: members matched by name (case-sensitive), strings left-justified and blank padded, numbers stored by decimal alignment; malformed text, a mistyped or non-fitting value is the exception condition under ON EXCEPTION (else a Hole); non-ASCII text, a repeated name, extra decimals, a negative for an unsigned item and an exponent are a Hole (the oracle has no JSON statement)",
+   "title": "JSON PARSE INTO a group of DISPLAY, COMP, COMP-3 and COMP-5 items: members matched by name (case-sensitive), strings left-justified and blank padded, numbers stored by decimal alignment; malformed text, a mistyped or non-fitting value is the exception condition under ON EXCEPTION (else a Hole); non-ASCII text, a repeated name, extra decimals, a negative for an unsigned item and an exponent are a Hole (the oracle has no JSON statement)",
    "methods": [
     "parse",
     "tryParse"

docs/language_status/register/X77.md

@@ -2,12 +2,13 @@
 id: "X77"
 family: "X"
 status: "ASSUMED"
-title: "JSON PARSE into a group of DISPLAY items is translated from IBM's text alone — ASSUMED, oracle-unbacked (#7524)"
+title: "JSON PARSE into a group of DISPLAY, COMP, COMP-3 and COMP-5 items is translated from IBM's text alone — ASSUMED, oracle-unbacked (#7524)"
 area: "COBOL"
-summary: "JSON PARSE source [WITH DETAIL] INTO group [NAME OF ... IS] [SUPPRESS item] over DISPLAY alphanumeric and fixed-point numeric items is generated as a runtime call that reads one JSON object and stores its members by name. GnuCOBOL has no JSON statement, so nothing backs it: no L2+ claim. ON EXCEPTION / NOT ON EXCEPTION are modelled for malformed text, a non-object, a type mismatch, a string longer than its item and a number that does not fit (the exception condition). JSON-CODE / JSON-STATUS, SUPPRESS WHEN / EVERY, CONVERTING, NAME OMITTED, tables, COMP / COMP-3 / float items, an elementary receiver and any character beyond ASCII stay holes or runtime Holes"
+summary: "JSON PARSE source [WITH DETAIL] INTO group [NAME OF ... IS] [SUPPRESS item] over DISPLAY alphanumeric text and fixed-point numbers (DISPLAY, COMP, COMP-3 / PACKED-DECIMAL, COMP-5) is generated as a runtime call that reads one JSON object and stores its members by name. GnuCOBOL has no JSON statement, so nothing backs it: no L2+ claim. ON EXCEPTION / NOT ON EXCEPTION are modelled for malformed text, a non-object, a type mismatch, a string longer than its item and a number that does not fit (the exception condition). JSON-CODE / JSON-STATUS, SUPPRESS WHEN / EVERY, CONVERTING, NAME OMITTED, tables, float items, an elementary receiver and any character beyond ASCII stay holes or runtime Holes"
 reached: "no (no burned program uses JSON; fixture tests/cobol_mainframe/test_det_json_parse.py)"
 ---
 - **What IBM says** (Enterprise COBOL for z/OS 6.3 Language Reference, JSON PARSE: https://www.ibm.com/docs/SS6SG3_6.3.0/lr/ref/rlpsjsop.html and its sub-pages). The members of the JSON object are matched by name to the subordinate items of the receiving group; a JSON name with no data item is ignored and an item with no JSON member is left unchanged; NAME OF renames an item, SUPPRESS leaves one out; a string goes to an alphanumeric item (left-justified, padded with spaces) and a number to a numeric item (aligned on the decimal point); WITH DETAIL only widens what the exception condition reports. A text that is not valid JSON, or a value that does not fit or has the wrong type, raises the exception condition (JSON-CODE nonzero, ON EXCEPTION).
 - **Modelled.** `det/stmt.py` `_json_parse` parses the statement, `det/gen.py` `json_parse` builds the receiving tree (shared with JSON GENERATE through `json_tree`) and refuses the shapes below by name, `cobolrt/JsonParse.java` reads and stores. A statement it cannot take keeps the `JSON PARSE (...): not modelled` hole text, with the reason for the shape appended.
 - **What we assume.** (1) The text is one JSON object whose members map to the group's subordinates; the group's own name is not in the text (unlike the GENERATE wrapper). (2) Names match case-sensitively and exactly. (3) The exception condition (#7524): with ON EXCEPTION / NOT ON EXCEPTION, malformed text, text that is not a JSON object, a value of the wrong type, a string longer than its item and a number too large for its item raise it (ON EXCEPTION runs, else NOT ON EXCEPTION); without the phrases each is a runtime `Hole`. Malformed text stores nothing; after a type or size failure the items matched before it keep the values stored (assumed: IBM's text is read as leaving the receiver unspecified, the model stores left to right). A number with more decimals than the item, a negative number for an unsigned item, an exponent, a repeated name in one object and any character beyond ASCII are a `Hole` even with the phrases, never a guess. JSON-CODE / JSON-STATUS are not set. (4) WITH DETAIL changes nothing the model reports, since only the exception condition uses it.
+- **Packed and binary numbers (#7524, #7709).** A COMP / COMP-3 / COMP-5 numeric receiver takes the number by the same rules as a DISPLAY one (decimal alignment, no extra decimals, no negative for an unsigned item, a value past the PICTURE digits is the exception condition); the store is the runtime's `Cobol.store`, IBM's text states no other byte layout. A table receiver stays refused for PARSE.
 - **Status:** ASSUMED, **oracle-unbacked**; a port using it is reported as assumed (IBM-documented). JSON-CODE / JSON-STATUS for both verbs, SUPPRESS WHEN / EVERY, CONVERTING and the wider item kinds are later slices of #7524.

gitgalaxy/tools/cobol_to_java/det/gen.py

@@ -3254,7 +3254,7 @@ def json_tree(self, d: dict, cls: str, what: str, src_ref: E.Ref) -> str:
         if src.category != "GROUP" or src_ref.subscripts or src_ref.refmod is not None:
             raise Untranslatable(f"{what}: {src.name} is not a plain group (an elementary item is not modelled)")
         seen: set[str] = set()
-        wide = cls == "JsonGenerate"  # #7524: packed / binary numbers and tables are modelled for GENERATE only
+        wide = cls == "JsonGenerate"  # #7524: tables are modelled for GENERATE only
         leaves = [0]
 
         def elem(it: L.Item, name: str, idx: tuple[int, ...], top: bool = False) -> str | None:
@@ -3269,7 +3269,7 @@ def elem(it: L.Item, name: str, idx: tuple[int, ...], top: bool = False) -> str
                 raise Untranslatable(
                     f"{what}: {it.name} is {it.usage} {it.category} (only text and numbers are modelled)"
                 )
-            if it.usage != "DISPLAY" and not (wide and numeric and it.usage in ("BINARY", "COMP-5", "PACKED")):
+            if it.usage != "DISPLAY" and not (numeric and it.usage in ("BINARY", "COMP-5", "PACKED")):
                 raise Untranslatable(
                     f"{what}: {it.name} is {it.usage} {it.category} (only DISPLAY text and numbers are modelled)"
                 )

tests/cobol_mainframe/test_det_json_generate.py

@@ -283,10 +283,11 @@ def test_a_table_as_the_source_itself_is_still_refused(tmp_path):
 
 
 def test_parse_does_not_take_what_only_generate_models(tmp_path):
-    """JSON PARSE keeps refusing COMP numbers and tables (its runtime has no node for them: a sibling slice)."""
-    for target in ("REC",):
-        r = _wide(tmp_path, f"JSON PARSE OUT INTO {target}")
-        assert len(r.stats["holes"]) == 1 and "JSON PARSE" in str(r.stats["holes"][0])
+    """JSON PARSE takes COMP numbers (#7524, X77) but still refuses tables (a sibling slice)."""
+    r = _wide(tmp_path, "JSON PARSE OUT INTO REC")
+    assert (
+        len(r.stats["holes"]) == 1 and "JSON PARSE" in str(r.stats["holes"][0]) and "table" in str(r.stats["holes"][0])
+    )
 
 
 @pytest.mark.skipif(_jdk() is None, reason="needs a JDK 17 (JAVA_HOME / JDK_17)")

tests/cobol_mainframe/test_det_json_parse.py

@@ -79,6 +79,107 @@ def test_a_shape_the_model_does_not_take_is_refused_by_name(tmp_path, stmt, why)
     assert "JSON PARSE (Enterprise COBOL 6.1+): not modelled" in hole and why in hole
 
 
+NUMS = """       IDENTIFICATION DIVISION.
+       PROGRAM-ID. PROG.
+       DATA DIVISION.
+       WORKING-STORAGE SECTION.
+       01  REC.
+           05  BIN-N    PIC S9(4) COMP.
+           05  PK-N     PIC S9(5)V99 COMP-3.
+           05  NAT-N    PIC 9(9) COMP-5.
+           05  PD-N     PIC 9(3) PACKED-DECIMAL.
+       01  TBL.
+           05  PK-T     PIC 9(3) COMP-3 OCCURS 2.
+       01  JIN  PIC X(100).
+       PROCEDURE DIVISION.
+"""
+
+
+def _nums(tmp_path, *body: str):
+    src = tmp_path / "PROG.cbl"
+    src.write_text(NUMS + "".join(f"           {b}\n" for b in body) + "           GOBACK.\n", encoding="utf-8")
+    return P.translate(src, [], "public class ProgService { }", "t")
+
+
+def test_comp_comp3_and_comp5_numbers_are_translated_for_parse(tmp_path):
+    r = _nums(tmp_path, "JSON PARSE JIN INTO REC")
+    assert r.stats["holes"] == []
+    line = next(x for x in r.java.splitlines() if "JsonParse.parse" in x)
+    for name in ("BIN-N", "PK-N", "NAT-N", "PD-N"):
+        assert f'number("{name}"' in line
+
+
+def test_a_table_receiver_is_still_refused_for_parse(tmp_path):
+    r = _nums(tmp_path, "JSON PARSE JIN INTO TBL")
+    assert len(r.stats["holes"]) == 1 and "table" in str(r.stats["holes"][0])
+
+
+@pytest.mark.skipif(_jdk() is None, reason="needs a JDK 17 (JAVA_HOME / JDK_17)")
+def test_the_runtime_stores_packed_and_binary_numbers(tmp_path):
+    from gitgalaxy.tools.cobol_to_java.cobol_to_java_transaction_forge import CICS_SPEC_JAVA, CICS_TASK_JAVA
+
+    src = tmp_path / "src"
+    files = {"t/cics/CicsTask.java": CICS_TASK_JAVA.replace("__PACKAGE__", "t").replace("__ZONE__", "UTC"),
+             "t/cics/CicsSpec.java": CICS_SPEC_JAVA.replace("__PACKAGE__", "t"),
+             **{f"t/{k}": v for k, v in P.runtime_files("t", batch=False).items()}}  # fmt: skip
+    files["Main.java"] = """
+import java.nio.charset.Charset;
+import t.cobolrt.Field;
+import t.cobolrt.JsonParse;
+import t.cobolrt.Storage;
+public class Main {
+    static Charset CS = Charset.forName("ISO-8859-1");
+    static String hex(Storage st, int off, int n) {
+        StringBuilder b = new StringBuilder();
+        for (int i = 0; i < n; i++) b.append(String.format("%02X", st.bytes[off + i] & 0xFF));
+        return b.toString();
+    }
+    static void run(String json, boolean tryIt) {
+        Storage st = new Storage(300);
+        byte[] j = json.getBytes(CS);
+        System.arraycopy(j, 0, st.bytes, 100, j.length);
+        for (int i = j.length; i < 100; i++) st.bytes[100 + i] = ' ';
+        try {
+            Field in = Field.alphanumeric(st, 100, 100, false);
+            Field p = Field.packed(st, 0, 5, 2, true);
+            Field b = Field.binary(st, 10, 4, 0, true, false);
+            Field u = Field.packed(st, 20, 3, 0, false);
+            JsonParse.Node g = JsonParse.group("G", JsonParse.number("P", p), JsonParse.number("B", b), JsonParse.number("U", u));
+            if (tryIt) {
+                boolean exc = JsonParse.tryParse(in, g, CS);
+                System.out.println((exc ? "EXC " : "OK ") + hex(st, 0, 3) + " " + hex(st, 10, 2) + " " + hex(st, 20, 2));
+            } else {
+                JsonParse.parse(in, g, CS);
+                System.out.println(hex(st, 0, 3) + " " + hex(st, 10, 2) + " " + hex(st, 20, 2));
+            }
+        } catch (RuntimeException e) {
+            System.out.println("HOLE " + e.getMessage());
+        }
+    }
+    public static void main(String[] x) {
+        run("{\\"P\\":-123.45,\\"B\\":-12,\\"U\\":7}", false);
+        run("{\\"P\\":1000.00}", true);
+        run("{\\"B\\":10000}", true);
+        run("{\\"U\\":-1}", true);
+        run("{\\"U\\":1.5}", true);
+    }
+}
+"""
+    for rel, text in files.items():
+        (src / rel).parent.mkdir(parents=True, exist_ok=True)
+        (src / rel).write_text(text, encoding="utf-8")
+    jdk = _jdk()
+    built = javac_run([str(jdk / "javac"), "-encoding", "UTF-8", "-nowarn", "-d", str(tmp_path / "classes"),
+                       *map(str, src.rglob("*.java"))], capture_output=True, text=True, encoding="utf-8", check=False)  # fmt: skip
+    assert built.returncode == 0, built.stderr
+    out = subprocess.run([str(jdk / "java"), "-Dfile.encoding=UTF-8", "-Dstdout.encoding=UTF-8", "-cp", str(tmp_path / "classes"), "Main"],  # noqa: S603
+                         capture_output=True, text=True, encoding="utf-8", check=True).stdout.splitlines()  # fmt: skip
+    assert out[0] == "12345D FFF4 007F", out[0]
+    assert out[1].startswith("EXC") and out[2].startswith("EXC")  # 1000.00 does not fit S9(5)V99; 10000 not S9(4)
+    assert out[3].startswith("HOLE") and "unsigned" in out[3]
+    assert out[4].startswith("HOLE") and "decimals" in out[4]
+
+
 def test_an_elementary_receiver_is_refused_by_name(tmp_path):
     r = _translate(tmp_path, "JSON PARSE JIN INTO CUST-NAME")
     assert len(r.stats["holes"]) == 1 and "JSON PARSE: CUST-NAME is not a plain group" in r.stats["holes"][0]