det: JSON GENERATE SUPPRESS ... WHEN / EVERY (Part of #7524)

docs/language_status/cobolrt_api.json

@@ -1,7 +1,7 @@
 {
   "schema": "cobolrt-api/1",
   "about": ["The cobolrt public API (#4718). Written by tests/tools/cobolrt_api.py generate: edit only a `visibility`, to public or internal; docs/cobolrt_api_contract.md says what they promise.", "`evidence` records who called the item when it was last refreshed, and is never checked: det-port, model-port (committed ports), frozen-overlay (a frozen runtime copy's call to a live class), generated (translator output), emitter (a translator string), emitter-dynamic (a name a computed emission may take), runtime, harness; empty: no caller was found."],
-  "summary": {"types": 128, "types_public": 105, "members": 1198, "members_public": 809, "members_internal": 389},
+  "summary": {"types": 128, "types_public": 105, "members": 1198, "members_public": 807, "members_internal": 391},
   "types": [
     {"id": "batch.CobolAbend", "kind": "class", "source": "gitgalaxy/tools/cobol_to_java/cobol_to_java_batch_forge.py", "variants": ["forge-batch-jobs", "forge-batch-files"], "supers": ["RuntimeException"], "visibility": "public", "evidence": ["det-port", "emitter", "model-port", "signature", "harness"], "members": [
       {"id": "batch.CobolAbend.<init>(String,String)", "kind": "constructor", "visibility": "internal", "evidence": []},
@@ -1010,8 +1010,8 @@
       {"id": "cobolrt.JsonGenerate.array(String,Node...)", "kind": "method", "static": true, "returns": "cobolrt.JsonGenerate.Node", "visibility": "public", "evidence": ["emitter-dynamic", "harness"]},
       {"id": "cobolrt.JsonGenerate.generate(Field,Node,Charset)", "kind": "method", "static": true, "returns": "int", "visibility": "public", "evidence": ["emitter", "harness"]},
       {"id": "cobolrt.JsonGenerate.group(String,Node...)", "kind": "method", "static": true, "returns": "cobolrt.JsonGenerate.Node", "visibility": "public", "evidence": ["emitter-dynamic", "harness"]},
-      {"id": "cobolrt.JsonGenerate.number(String,Field)", "kind": "method", "static": true, "returns": "cobolrt.JsonGenerate.Node", "visibility": "public", "evidence": ["harness"]},
-      {"id": "cobolrt.JsonGenerate.text(String,Field)", "kind": "method", "static": true, "returns": "cobolrt.JsonGenerate.Node", "visibility": "public", "evidence": ["harness"]},
+      {"id": "cobolrt.JsonGenerate.number(String,Field,String...)", "kind": "method", "static": true, "returns": "cobolrt.JsonGenerate.Node", "visibility": "internal", "evidence": ["harness"]},
+      {"id": "cobolrt.JsonGenerate.text(String,Field,String...)", "kind": "method", "static": true, "returns": "cobolrt.JsonGenerate.Node", "visibility": "internal", "evidence": ["harness"]},
       {"id": "cobolrt.JsonGenerate.tryGenerate(Field,Node,Charset)", "kind": "method", "static": true, "returns": "int", "visibility": "public", "evidence": ["emitter", "harness", "runtime"]}
     ]},
     {"id": "cobolrt.JsonGenerate.Node", "kind": "class", "source": "gitgalaxy/tools/cobol_to_java/det/cobolrt/JsonGenerate.java", "variants": ["det-batch", "det-standalone", "sort-job"], "supers": [], "visibility": "public", "evidence": ["signature", "harness", "runtime"], "members": [

docs/language_status/cobolrt_rules.json

@@ -118,6 +118,8 @@
     "array",
     "read",
     "invalid",
+    "skip",
+    "allBytes",
     "text",
     "number",
     "quote",
@@ -601,7 +603,7 @@
   {
    "id": "RT-CBL-JSON-GENERATE",
    "family": "CBL",
-   "title": "JSON GENERATE from a group of DISPLAY, COMP / COMP-3 / COMP-5 items and fixed tables (an array per table): names as written, members in storage order, trailing blanks trimmed, numbers as edited, bytes written to the receiver and counted; a receiver too small is the exception condition under ON EXCEPTION (else a Hole), non-digit numeric data is a Hole (the oracle has no JSON statement)",
+   "title": "JSON GENERATE from a group of DISPLAY, COMP / COMP-3 / COMP-5 items and fixed tables (an array per table): names as written, members in storage order, trailing blanks trimmed, numbers as edited, bytes written to the receiver and counted; a receiver too small is the exception condition under ON EXCEPTION (else a Hole), SUPPRESS ... WHEN / EVERY leaves out an item whose value is ZERO / SPACE / LOW-VALUE / HIGH-VALUE, non-digit numeric data is a Hole (the oracle has no JSON statement)",
    "methods": [
     "generate",
     "tryGenerate"

docs/language_status/register/X76.md

@@ -4,11 +4,12 @@ family: "X"
 status: "ASSUMED"
 title: "JSON GENERATE from a group of DISPLAY, COMP / COMP-3 / COMP-5 items and fixed tables is translated from IBM's text alone — ASSUMED, oracle-unbacked (#7524)"
 area: "COBOL"
-summary: "JSON GENERATE identifier-1 FROM group [COUNT IN] [NAME OF ... IS] [SUPPRESS item] over DISPLAY alphanumeric, fixed-point numeric (DISPLAY, COMP, COMP-3, COMP-5) items and fixed OCCURS tables is generated as a runtime call that writes IBM's JSON text (names as written, group wrapper, trailing blanks trimmed, numbers as edited). GnuCOBOL has no JSON statement, so nothing backs it: no L2+ claim. JSON-CODE after an exception, SUPPRESS WHEN / EVERY, CONVERTING, NAME OMITTED, OCCURS DEPENDING ON, a table as the source itself, float items, an elementary source and any character beyond ASCII stay holes or runtime Holes"
+summary: "JSON GENERATE identifier-1 FROM group [COUNT IN] [NAME OF ... IS] [SUPPRESS item [WHEN ...] | EVERY [NUMERIC | NONNUMERIC] WHEN ...] over DISPLAY alphanumeric, fixed-point numeric (DISPLAY, COMP, COMP-3, COMP-5) items and fixed OCCURS tables is generated as a runtime call that writes IBM's JSON text (names as written, group wrapper, trailing blanks trimmed, numbers as edited). GnuCOBOL has no JSON statement, so nothing backs it: no L2+ claim. JSON-CODE after an exception, CONVERTING, NAME OMITTED, OCCURS DEPENDING ON, a table as the source itself, float items, an elementary source and any character beyond ASCII stay holes or runtime Holes"
 reached: "no (no burned program uses JSON; fixture tests/cobol_mainframe/test_det_json_generate.py)"
 ---
-- **What IBM says** (Enterprise COBOL for z/OS 6.3 Language Reference, JSON GENERATE: https://www.ibm.com/docs/SS6SG3_6.3.0/lr/ref/rlpsjsog.html and its sub-pages). Data names are written as they are spelled in the program (case and hyphens kept); the source group's own name wraps its members as `{"GROUP":{...}}`; trailing spaces of an alphanumeric item are trimmed, an all-space item becomes one space; `"` `\` and control characters are escaped; a number is written as edited (a leading `-` for a negative value, leading zeros dropped to one integer digit, the decimals kept, no sign for a positive value); COUNT IN receives the bytes generated; FILLER / unnamed items, REDEFINES items and groups whose members are all ignored are left out; names must be unique; SUPPRESS names an item (a group takes its subtree); NAME OF renames an item; a receiver too small raises the exception condition (JSON-CODE nonzero, receiver undefined; ON EXCEPTION runs, else NOT ON EXCEPTION).
+- **What IBM says** (Enterprise COBOL for z/OS 6.3 Language Reference, JSON GENERATE: https://www.ibm.com/docs/SS6SG3_6.3.0/lr/ref/rlpsjsog.html and its sub-pages). Data names are written as they are spelled in the program (case and hyphens kept); the source group's own name wraps its members as `{"GROUP":{...}}`; trailing spaces of an alphanumeric item are trimmed, an all-space item becomes one space; `"` `\` and control characters are escaped; a number is written as edited (a leading `-` for a negative value, leading zeros dropped to one integer digit, the decimals kept, no sign for a positive value); COUNT IN receives the bytes generated; FILLER / unnamed items, REDEFINES items and groups whose members are all ignored are left out; names must be unique; SUPPRESS names an item (a group takes its subtree); SUPPRESS item WHEN names an elementary item and leaves it out when its value is one of the listed figuratives (ZERO is a numeric comparison for a number, SPACE / LOW-VALUE / HIGH-VALUE select USAGE DISPLAY items, of the numeric ones only integers), SUPPRESS EVERY [NUMERIC | NONNUMERIC] WHEN does so for every item of that class, and a group left with no member goes too while the source group itself is always written (`{"A":{}}`); NAME OF renames an item; a receiver too small raises the exception condition (JSON-CODE nonzero, receiver undefined; ON EXCEPTION runs, else NOT ON EXCEPTION).
 - **Modelled.** `det/stmt.py` `_json_generate` parses the statement, `det/gen.py` `json_generate` builds the member tree and refuses the shapes below by name, `cobolrt/JsonGenerate.java` writes the text as US-ASCII bytes into the receiver (the bytes past the text are untouched). A JSON statement it cannot take keeps the `JSON GENERATE (...): not modelled` hole text, with the reason for the shape appended.
 - **What we assume.** (1) The elementary-source wrapper, the JSON-CODE values and a negative zero are not stated precisely enough: each is refused, not guessed. (2) Output is 7-bit ASCII only (UTF-8 and the EBCDIC code page agree there); any other character is a runtime `Hole`. (3) Non-digit data in a numeric DISPLAY item is **undefined by IBM** (register C11, family U): a runtime `Hole`. (4) A receiver shorter than the text is IBM's exception condition. With ON EXCEPTION / NOT ON EXCEPTION the port takes the exception branch and leaves the receiver and COUNT IN as they were (IBM leaves them undefined, so a program reading them there reads undefined data); without either phrase IBM sets JSON-CODE, which is not modelled: a runtime `Hole`. (5) A fixed table is an array under the item's name: an elementary item gives an array of values, a group an array of objects (IBM's table format); at most 256 items and elements are taken. A packed item with an invalid digit or sign nibble, or a binary item past its PICTURE digits, is undefined by IBM (C11): a runtime `Hole`. A COMP-5 item that overlaps another COMP-5 byte range is refused (its bytes are the oracle's). JSON PARSE keeps DISPLAY-only, table-free shapes. (6) IBM's DISPLAY has no ON EXCEPTION, so the phrases after a DISPLAY inside the first phrase belong to the JSON GENERATE. JSON PARSE and XML statements keep their phrases inside the hole.
-- **Status:** ASSUMED, **oracle-unbacked**. GnuCOBOL has no JSON statement (the equivalence harness cannot compare it), so no L2+ claim rests on this entry; a port using it is reported as assumed (IBM-documented). JSON PARSE (X77), JSON-CODE after an exception, SUPPRESS WHEN / EVERY and DEPENDING ON tables are later slices of #7524.
+- **Status:** ASSUMED, **oracle-unbacked**. GnuCOBOL has no JSON statement (the equivalence harness cannot compare it), so no L2+ claim rests on this entry; a port using it is reported as assumed (IBM-documented). JSON PARSE (X77), JSON-CODE after an exception, CONVERTING, NAME OMITTED and DEPENDING ON tables are later slices of #7524.
+- **SUPPRESS ... WHEN / EVERY (#7524).** The figuratives are read per the IBM page (ZERO / ZEROS / ZEROES, SPACE(S), LOW-VALUE(S), HIGH-VALUE(S), joined by OR). Assumed: ZERO on an alphanumeric item is an alphanumeric comparison with ZEROS (every character `0`); SPACE / LOW-VALUE / HIGH-VALUE compare the item's bytes (SPACE is the code page's blank); a number equal to zero is suppressed by ZERO, so invalid data in it is a runtime `Hole` (C11) and a negative zero stays one. A named WHEN on a group, or on a USAGE the figurative does not select, is refused by name; the generic phrase silently skips the items it does not select. An item inside an OCCURS table is refused by name (the LR does not say whether one element or the table goes). JSON PARSE keeps refusing WHEN / EVERY.
 - **JSON-CODE (#7524).** A program that names JSON-CODE gets a hidden S9(4) item, set to 0 after a JSON GENERATE that raised no exception (the LR states this). The code IBM sets for an exception is in the Programming Guide's exception table, which the model does not state: a program that names JSON-CODE and has a JSON GENERATE with ON / NOT ON EXCEPTION, or any JSON PARSE, is refused by name. A program's own JSON-CODE item is kept.

gitgalaxy/tools/cobol_to_java/det/cobolrt/JsonGenerate.java

@@ -36,6 +36,11 @@ void render(StringBuilder out, Charset cs) {
 
         /** The value alone: what an element of a table is. */
         abstract void value(StringBuilder out, Charset cs);
+
+        /** True when SUPPRESS ... WHEN leaves this member out (its value is one of the WHEN figuratives, or, for a group, all its members are). */
+        boolean skip(Charset cs) {
+            return false;
+        }
     }
 
     /** A table (OCCURS): `"name":[element,...]`, each element a value without a name (an object for a group). */
@@ -49,18 +54,20 @@ public static Node group(String name, Node... members) {
     }
 
     /** An alphanumeric / alphabetic elementary item: `"name":"text"`, trailing spaces trimmed, one space if all spaces. */
-    public static Node text(String name, Field f) {
-        return new Text(name, f);
+    public static Node text(String name, Field f, String... when) {
+        return new Text(name, f, when);
     }
 
     /** A fixed-point DISPLAY number: `"name":-12.340`, leading zeros dropped, a plus sign never written. */
-    public static Node number(String name, Field f) {
-        return new Number(name, f);
+    public static Node number(String name, Field f, String... when) {
+        return new Number(name, f, when);
     }
 
     /**
      * Writes `{root}` to `into` (the root's name is the source group's, or its NAME literal) and returns the
-     * number of bytes generated (COUNT IN).
+     * number of bytes generated (COUNT IN). `when` on an item (ZERO, SPACE, LOW-VALUE, HIGH-VALUE) is SUPPRESS ... WHEN:
+     * the item is left out when its value matches, and a group whose members are all left out goes with them; the
+     * root group is always written (IBM: `{"A":{}}`).
      */
     // [rule RT-CBL-JSON-GENERATE]
     public static int generate(Field into, Node root, Charset cs) {
@@ -129,14 +136,46 @@ private static final class Group extends Node {
         @Override
         void value(StringBuilder out, Charset cs) {
             out.append('{');
-            for (int i = 0; i < members.size(); i++) {
-                if (i > 0) {
+            boolean first = true;
+            for (Node m : members) {
+                if (m.skip(cs)) {
+                    continue;
+                }
+                if (!first) {
                     out.append(',');
                 }
-                members.get(i).render(out, cs);
+                first = false;
+                m.render(out, cs);
             }
             out.append('}');
         }
+
+        @Override
+        boolean skip(Charset cs) {
+            for (Node m : members) {
+                if (!m.skip(cs)) {
+                    return false;
+                }
+            }
+            return true;
+        }
+    }
+
+    /**
+     * Whether `raw` is entirely the figurative `w` (SPACE, LOW-VALUE, HIGH-VALUE; the byte of SPACE is the code page's).
+     */
+    private static boolean allBytes(byte[] raw, String w, Charset cs) {
+        byte b = switch (w) {
+            case "SPACE" -> " ".getBytes(cs)[0];
+            case "LOW-VALUE" -> (byte) 0x00;
+            default -> (byte) 0xFF;
+        };
+        for (byte x : raw) {
+            if (x != b) {
+                return false;
+            }
+        }
+        return true;
     }
 
     private static final class Array extends Node {
@@ -162,10 +201,23 @@ void value(StringBuilder out, Charset cs) {
 
     private static final class Text extends Node {
         final Field f;
+        final String[] when;
 
-        Text(String name, Field f) {
+        Text(String name, Field f, String[] when) {
             super(name);
             this.f = f;
+            this.when = when;
+        }
+
+        /** ZERO on text is an alphanumeric comparison with ZEROS: every character a `0`. */
+        @Override
+        boolean skip(Charset cs) {
+            for (String w : when) {
+                if (w.equals("ZERO") ? Cobol.text(f, cs).chars().allMatch(c -> c == '0') : allBytes(f.raw(), w, cs)) {
+                    return true;
+                }
+            }
+            return false;
         }
 
         @Override
@@ -181,10 +233,28 @@ void value(StringBuilder out, Charset cs) {
 
     private static final class Number extends Node {
         final Field f;
+        final String[] when;
 
-        Number(String name, Field f) {
+        Number(String name, Field f, String[] when) {
             super(name);
             this.f = f;
+            this.when = when;
+        }
+
+        /** ZERO is a numeric comparison (invalid data and negative zero are the Holes of {@link #read}); the others
+         *  compare the bytes of a DISPLAY integer. */
+        @Override
+        boolean skip(Charset cs) {
+            for (String w : when) {
+                if (w.equals("ZERO")) {
+                    if (read(cs).signum() == 0) {
+                        return true;
+                    }
+                } else if (allBytes(f.raw(), w, cs)) {
+                    return true;
+                }
+            }
+            return false;
         }
 
         /** The value, or a Hole where IBM documents no result (invalid data) or the model is silent (negative zero). */

gitgalaxy/tools/cobol_to_java/det/gen.py

@@ -3250,6 +3250,15 @@ def json_tree(self, d: dict, cls: str, what: str, src_ref: E.Ref) -> str:
         is refused by name."""
         names = {id(self.resolve(r)): lit for r, lit in d["names"]}
         suppressed = {id(self.resolve(r)) for r in d["suppress"]}
+        # #7524: SUPPRESS item WHEN figurative ... (an elementary item) and SUPPRESS EVERY [NUMERIC | NONNUMERIC] WHEN ...
+        named_when: dict[int, list[str]] = {}
+        for r, vals in d["when"]:
+            w = self.resolve(r)
+            if w.category == "GROUP":
+                raise Untranslatable(f"{what}: SUPPRESS {w.name} WHEN names a group (IBM needs an elementary item)")
+            if any(v != "ZERO" and not self.json_when_fits(w, v) for v in vals):
+                raise Untranslatable(f"{what}: SUPPRESS {w.name} WHEN {' OR '.join(vals)} does not fit its usage")
+            named_when.setdefault(id(w), []).extend(vals)
         src = self.resolve(src_ref)
         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)")
@@ -3289,7 +3298,14 @@ def elem(it: L.Item, name: str, idx: tuple[int, ...], top: bool = False) -> str
             leaves[0] += 1
             if leaves[0] > JSON_TABLE_LEAVES:
                 raise Untranslatable(f"{what}: more than {JSON_TABLE_LEAVES} items and table elements (not modelled)")
-            return f"__PACKAGE__.cobolrt.{cls}.{'number' if numeric else 'text'}({jstr(name)}, {f})"
+            vals = list(named_when.get(id(it), []))
+            for kind, gv in d["generic"]:
+                if kind is None or (kind == "NUMERIC") == numeric:
+                    vals += [v for v in gv if v == "ZERO" or self.json_when_fits(it, v)]
+            if vals and idx:
+                raise Untranslatable(f"{what}: SUPPRESS ... WHEN on {it.name}, an item in a table (not modelled)")
+            wh = "".join(f", {jstr(v)}" for v in dict.fromkeys(vals))
+            return f"__PACKAGE__.cobolrt.{cls}.{'number' if numeric else 'text'}({jstr(name)}, {f}{wh})"
 
         def node(it: L.Item, top: bool, idx: tuple[int, ...]) -> str | None:
             """The Java node of `it`, or None when IBM leaves it out (FILLER, REDEFINES, SUPPRESSed, an empty group)."""
@@ -3326,6 +3342,12 @@ def node(it: L.Item, top: bool, idx: tuple[int, ...]) -> str | None:
 
         return node(src, True, ()) or ""
 
+    @staticmethod
+    def json_when_fits(it: L.Item, value: str) -> bool:
+        """IBM (JSON GENERATE, SUPPRESS ... WHEN): SPACE, LOW-VALUE and HIGH-VALUE select USAGE DISPLAY items, and of the
+        zoned decimal ones only integers; ZERO selects every item."""
+        return value == "ZERO" or (it.usage == "DISPLAY" and (it.category != "NUMERIC" or it.scale == 0))
+
     def json_generate(self, s: S.Stmt, ind: str) -> list[str]:
         """#7524: JSON GENERATE from a group of DISPLAY alphanumeric / numeric items (Enterprise COBOL 6.3 LR, X76)."""
         d = s.data