CICS: READQ TD / DELETEQ TD on an intrapartition queue (Part of #5079)

docs/language_status/cobolrt_rules.json

@@ -2097,6 +2097,25 @@
    "status": "ASSUMED",
    "calibration": "uncalibrated"
   },
+  {
+   "id": "RT-CICS-READQ-TD-INTO",
+   "family": "CICS",
+   "title": "READQ TD INTO: the record (cut to LENGTH) goes INTO, the rest of INTO as it was; a record moved past INTO refused",
+   "methods": [
+    "readTd"
+   ],
+   "ibm": {
+    "doc": "cics-apr",
+    "section": "READQ TD: INTO, LENGTH"
+   },
+   "options": [],
+   "register": [
+    "X6",
+    "X57"
+   ],
+   "status": "ASSUMED",
+   "calibration": "uncalibrated"
+  },
   {
    "id": "RT-CICS-BIF-DEEDIT",
    "family": "CICS",

docs/language_status/register/X57.md

@@ -0,0 +1,39 @@
+---
+id: "X57"
+family: "X"
+status: "ASSUMED (REFUSED where IBM is silent)"
+title: "READQ TD / DELETEQ TD on an intrapartition queue — ASSUMED, REFUSED where IBM is silent (#5079)"
+area: "CICS"
+summary: "READQ TD QUEUE INTO [LENGTH]: a destructive, first-in first-out read of the queue the task's own WRITEQ TDs fill; QZERO for an empty queue, QIDERR for a queue the CSD does not define, LENGERR (the record read and lost, INTO holding its first LENGTH bytes) for a record longer than LENGTH or a LENGTH of zero, LENGERR with nothing read for a negative LENGTH, LENGTH set to the record's own length. DELETEQ TD: every record of an intrapartition queue; QIDERR; INVREQ for an extrapartition queue. Refused by name: READQ TD of an extrapartition queue (and of any queue whose CSD TYPE is neither INTRA nor EXTRA), READQ TD SET / SYSID / NOSUSPEND, DELETEQ TD SYSID and of a queue with a TYPE other than INTRA / EXTRA, a record moved past INTO. The WRITEQ TD event keeps its shape"
+reached: "no corpus program issues either command yet; proven on both runtimes with hand-traced operation lists (tests/cics_crucible/test_td_queue_5079.py) and the translator's refusals (tests/cobol_mainframe/test_equivalence_cics.py)"
+---
+- **READQ TD** (CICS TS 6.x, https://www.ibm.com/docs/en/cics-ts/6.x?topic=summary-readq-td). "Each READQ TD consumes the record it
+  reads": the read is destructive. QUEUE (1-4 characters), INTO or SET, LENGTH, NOSUSPEND, SYSID. Conditions: QZERO (23) "the queue is
+  empty or the end has been reached"; QIDERR (44) the queue name cannot be found; LENGERR (22) the INTO area cannot hold the data or
+  the length is invalid: a LENGTH below zero raises it and the queue is not read, a LENGTH of zero raises it and the queue is still
+  read, a record longer than LENGTH is truncated to LENGTH and raises it; after a read LENGTH is set to the record's original length.
+  NOTOPEN (19), IOERR (17) and INVREQ (16, "an extrapartition queue opened for output was named") concern extrapartition queues;
+  QBUSY (25) only arises with NOSUSPEND or an active HANDLE; DISABLED, ISCINVREQ, LOCKED, NOTAUTH, SYSIDERR need a region the run does not
+  have. The page lists no ENDFILE: QZERO is the end-of-queue condition, so ENDFILE is not modelled.
+- **DELETEQ TD** (https://www.ibm.com/docs/en/cics-ts/6.x?topic=summary-deleteq-td). "Deletes all transient data in a queue": an
+  intrapartition queue's records go; an extrapartition queue "cannot be deleted" and raises INVREQ (16); QIDERR (44) for a queue that
+  cannot be found. LOCKED, DISABLED, NOTAUTH, ISCINVREQ, SYSIDERR: not modelled (one task, no security, no remote queue). IBM lists no
+  RESP2 for any of them (so 0).
+- **What the runtimes do.** An intrapartition queue is a first-in first-out list in the run (the stub's files under the TS root,
+  `td-<hex of the name>/`, shared by the tasks of one conversation as TS queues are; `CicsTask.TempStorage.td`): a WRITEQ TD to a
+  defined intrapartition queue appends its record as well as recording its event (the WRITEQ TD event is unchanged: queue, text,
+  resp), READQ TD removes the first, DELETEQ TD empties the queue. The queue's TYPE comes from the case's CSD (`DEFINE TDQUEUE(Q)
+  ... TYPE(INTRA|EXTRA)`: `tdqueues.cfg` has a TYPE column, `CicsTask.withTdQueueTypes`); with no CSD every queue is defined and
+  intrapartition. READQ TD records an event on both sides ({queue, resp, data}: the text of what went INTO, none when nothing was
+  read); DELETEQ TD records none, as DELETEQ TS does, and shows through the RESP and the reads after it. LENGTH of a data area is
+  set on NORMAL and LENGERR with a record read; a literal or `LENGTH OF` is the most INTO takes and is set nowhere.
+- **Assumed.** (1) A queue is empty before the task writes to it: IBM says nothing of records a queue holds when the region starts
+  (a case cannot seed one yet). (2) A WRITEQ TD to an intrapartition queue is committed at once: no logical recoverability, so a
+  SYNCPOINT ROLLBACK does not undo it and a read sees a write of the same task. (3) A WRITEQ TD of LENGTH 0 queues an empty record,
+  which a READQ TD reads as length 0 with NORMAL.
+- **Refused by name.** READQ TD of an extrapartition queue (IBM's NOTOPEN / IOERR / INVREQ depend on the queue's open state and
+  on a data set the run does not have) and of a queue defined with a TYPE other than INTRA or EXTRA (INDIRECT, REMOTE) or none
+  (stub and port stop at the statement, "not modelled"); DELETEQ TD of the same other types; SET (the address of CICS's copy of the
+  data is not modelled), SYSID (a remote system is not modelled), NOSUSPEND (QBUSY needs a second task); a record moved past INTO
+  (a READQ TD whose LENGTH exceeds INTO, as READ INTO's: GnuCOBOL lays the storage after INTO out unlike IBM's compiler, X6).
+- **Status:** ASSUMED where listed, REFUSED where IBM is silent. The oracle is GnuCOBOL plus the stub, not z/OS.

gitgalaxy/standards/cics/commands/api.py

@@ -173,8 +173,6 @@
     ),
     ("ADDRESS SET", None, "setting a pointer from a data area's address (or the reverse) is not modelled"),
     # queues and files beyond the modelled ones
-    ("READQ TD", None, "reading a transient-data queue is not modelled (only WRITEQ TD)"),
-    ("DELETEQ TD", None, "deleting a transient-data queue is not modelled"),
     ("RESETBR", None, "repositioning a browse (RESETBR) is not modelled"),
     # journals
     ("JOURNAL", None, _JOURNAL),

gitgalaxy/standards/cics/commands/queues.py

@@ -8,15 +8,16 @@
 # of this project, or at https://polyformproject.org/licenses/noncommercial/1.0.0/
 # ==============================================================================
 """#4270 spec PR 2: queues -- WRITEQ TD, WRITEQ TS / READQ TS (det/cics.py Cics.command, Cics.ts_queue), each item the
-program's own bytes in the region's code page (#4528).
+program's own bytes in the region's code page (#4528). #5079, register X57: READQ TD / DELETEQ TD on an intrapartition
+queue (a first-in first-out queue the task's own WRITEQ TDs fill).
 
 A refused option shows no reason but SYSID's and READQ TS SET's (the reasons the old global table gave them). MAIN /
 AUXILIARY say where CICS keeps an item, not what it holds; NOSUSPEND: one task, a queue never waits."""
 
 from __future__ import annotations
 
 from gitgalaxy.standards.cics.commands.shared import RESP_OPTIONS, SET_POINTER, SYSID_REMOTE, ibm
-from gitgalaxy.standards.cics.model import Arg, Command, EngineFacts, Outcome, one_of
+from gitgalaxy.standards.cics.model import Arg, Command, EngineFacts, Outcome, Refusal, one_of, required
 
 _QUEUE = {"TS": Arg("flag"), "QUEUE": Arg("name", width=16), "QNAME": Arg("name", width=16)}
 _NO_QUEUE = "{} TS without QUEUE / QNAME"  # (det/cics.py Cics.ts_queue)
@@ -106,4 +107,59 @@
     engine=EngineFacts(resource="QUEUE", access="delete"),
 )
 
-COMMANDS = (WRITEQ_TD, WRITEQ_TS, READQ_TS, DELETEQ_TS)
+_TD_NOSUSPEND = Refusal(
+    "a queue another task is writing (QBUSY, a wait) is not modelled: one task, a queue never waits", "X57"
+)
+
+# #5079, register X57. IBM (EXEC CICS READQ TD): a destructive read ("the record is no longer available"); QZERO (23) for an
+# empty queue, QIDERR (44) for a queue CICS cannot find, LENGERR (22) for a record longer than LENGTH (truncated), or a
+# LENGTH below zero (the queue is then not read) or of zero (the record is still read and lost), LENGTH set to the record's
+# own length. An extrapartition queue (READQ: NOTOPEN / IOERR / INVREQ for one opened for output) is refused at run time.
+READQ_TD = Command(
+    key="READQ TD",
+    ibm=ibm("EXEC CICS READQ TD", "summary-readq-td"),
+    status="modelled",
+    register="X57",
+    options={
+        "QUEUE": Arg("name", width=4),
+        "INTO": Arg("area_out"),
+        "LENGTH": Arg("area_inout", width=2, binary=True, inout_unless_literal=True),
+        **RESP_OPTIONS,
+    },
+    refused={"SYSID": SYSID_REMOTE, "SET": SET_POINTER, "NOSUSPEND": _TD_NOSUSPEND},
+    groups=(required("QUEUE", msg="READQ TD without QUEUE"), required("INTO", msg="READQ TD without INTO")),
+    outcomes=(
+        Outcome("NORMAL", 0, "", writes=("INTO", "LENGTH")),
+        Outcome("QZERO", None, "the queue is empty"),
+        Outcome("QIDERR", None, "the CSD does not define the queue"),
+        Outcome(
+            "LENGERR",
+            None,
+            "the record is longer than LENGTH (truncated, and lost), or LENGTH is below zero",
+            writes=("INTO", "LENGTH"),
+        ),
+    ),
+    state=("handle_table",),
+    engine=EngineFacts(resource="QUEUE", access="read"),
+)
+
+# #5079, register X57. IBM (EXEC CICS DELETEQ TD): all the data of an intrapartition queue; INVREQ (16) for an
+# extrapartition queue, QIDERR (44) for one CICS cannot find. LOCKED / DISABLED / NOTAUTH / ISCINVREQ / SYSIDERR do not arise here.
+DELETEQ_TD = Command(
+    key="DELETEQ TD",
+    ibm=ibm("EXEC CICS DELETEQ TD", "summary-deleteq-td"),
+    status="modelled",
+    register="X57",
+    options={"QUEUE": Arg("name", width=4), **RESP_OPTIONS},
+    refused={"SYSID": SYSID_REMOTE},
+    groups=(required("QUEUE", msg="DELETEQ TD without QUEUE"),),
+    outcomes=(
+        Outcome("NORMAL", 0, ""),
+        Outcome("QIDERR", None, "the CSD does not define the queue"),
+        Outcome("INVREQ", None, "the queue is extrapartition"),
+    ),
+    state=("handle_table",),
+    engine=EngineFacts(resource="QUEUE", access="delete"),
+)
+
+COMMANDS = (WRITEQ_TD, WRITEQ_TS, READQ_TS, DELETEQ_TS, READQ_TD, DELETEQ_TD)

gitgalaxy/tools/cobol_to_java/cobol_to_java_transaction_forge.py

@@ -524,6 +524,7 @@ def commarea_alternative_todos(commarea: dict) -> list[str]:
     private String applid;
     private String sysid;
     private java.util.Set<String> tdQueues;
+    private java.util.Map<String, String> tdTypes;
 
     /** The region's identity (ASSIGN APPLID / SYSID): a deployment fact, set by whoever runs the task. */
     public CicsTask withRegion(String applid, String sysid) {
@@ -2047,18 +2048,92 @@ def commarea_alternative_todos(commarea: dict) -> list[str]:
         return this;
     }
 
+    /** Each transient-data queue's TYPE ("" when the CSD states none): INTRA, EXTRA, INDIRECT or REMOTE (#5079, X57).
+     *  Without it, a queue is intrapartition. */
+    public CicsTask withTdQueueTypes(java.util.Map<String, String> types) {
+        this.tdTypes = types;
+        return this;
+    }
+
+    /** The queue's kind: 0 the CSD does not define it, 1 intrapartition (TYPE INTRA, or no types given), 2 extrapartition,
+     *  3 any other TYPE or none stated -- a queue READQ TD / DELETEQ TD do not model. */
+    private int tdKind(String q) {
+        CicsTask root = root();
+        if (root.tdQueues != null && !root.tdQueues.contains(q)) {
+            return 0;
+        }
+        if (root.tdTypes == null) {
+            return 1;
+        }
+        String type = root.tdTypes.getOrDefault(q, "");
+        return type.equals("INTRA") ? 1 : type.equals("EXTRA") ? 2 : 3;
+    }
+
     /** WRITEQ TD QUEUE(queue) FROM(record) (IBM CICS TS): one record on a transient-data queue -- recorded, with the
-     *  record's text, and compared (CardDemo's CORPT00C submits JCL through JOBS). QIDERR (44) for a queue the
-     *  CSD does not define, or the condition the harness planned; then nothing is written. */
+     *  record's text, and compared (CardDemo's CORPT00C submits JCL through JOBS) -- and appended to an intrapartition
+     *  queue for a READQ TD to read (#5079). QIDERR (44) for a queue the CSD does not define, or the condition the
+     *  harness planned; then nothing is written. */
     public int writeqTd(String queue, String record) {
         String q = queue.strip();
+        int kind = tdKind(q);
         int[] planned = root().injected("WRITEQ-TD", q);
-        int resp = planned != null ? planned[0]
-                : root().tdQueues != null && !root().tdQueues.contains(q) ? 44 : 0;
+        int resp = planned != null ? planned[0] : kind == 0 ? 44 : 0;
         event("WRITEQ-TD", "queue", q, "text", resp == 0 ? record : null, "resp", resp);
+        if (resp == 0 && kind == 1) {
+            tempStorage.td.computeIfAbsent(q, k -> new java.util.ArrayDeque<>()).addLast(record);
+        }
         return resp;
     }
 
+    /** READQ TD QUEUE(queue) INTO LENGTH(maxLength) (#5079, IBM EXEC CICS READQ TD, X57): a destructive read, first in
+     *  first out. QIDERR when the CSD does not define the queue; QZERO when it holds no record; LENGERR for a negative
+     *  maxLength (nothing is read) or a record longer than maxLength (the record is read, so lost, and the result holds
+     *  its first maxLength characters); the result's length is the record's own. An extrapartition queue is refused. */
+    public TdResult readqTd(String queue, int maxLength) {
+        String q = queue.strip();
+        int kind = tdKind(q);
+        if (kind == 2) {
+            throw new UnsupportedOperationException("READQ TD of an extrapartition queue: IBM's NOTOPEN / IOERR / INVREQ "
+                    + "need the queue's open state, not modelled");
+        }
+        if (kind == 3) {
+            throw new UnsupportedOperationException("READQ TD of a queue whose TYPE is not INTRA: not modelled");
+        }
+        java.util.ArrayDeque<String> records = tempStorage.td.get(q);
+        String resp = kind == 0 ? "QIDERR" : maxLength < 0 ? "LENGERR" : records == null || records.isEmpty() ? "QZERO" : "NORMAL";
+        String data = null;
+        int length = -1;
+        if (kind != 0 && maxLength >= 0 && records != null && !records.isEmpty()) {
+            String record = records.removeFirst();
+            data = record.length() > maxLength ? record.substring(0, maxLength) : record;
+            length = record.length();
+            resp = record.length() > maxLength ? "LENGERR" : "NORMAL";
+        } else if (resp.equals("LENGERR")) {
+            data = "";
+        }
+        event("READQ-TD", "queue", q, "resp", resp, "data", data);
+        return new TdResult(CicsSpec.resp(resp), length, data);
+    }
+
+    /** DELETEQ TD QUEUE(queue) (#5079, IBM EXEC CICS DELETEQ TD, X57): every record of an intrapartition queue. QIDERR
+     *  (44) when the CSD does not define it, INVREQ (16) for an extrapartition queue. Returns RESP (RESP2 is 0). */
+    public int deleteqTd(String queue) {
+        String q = queue.strip();
+        int kind = tdKind(q);
+        if (kind == 3) {
+            throw new UnsupportedOperationException("DELETEQ TD of a queue whose TYPE is not INTRA or EXTRA: not modelled");
+        }
+        if (kind != 1) {
+            return kind == 0 ? 44 : 16;
+        }
+        tempStorage.td.remove(q);
+        return 0;
+    }
+
+    /** A READQ TD's outcome: RESP, the record's own length (-1 when none was read) and the text moved INTO (null when none). */
+    public record TdResult(int resp, int length, String data) {
+    }
+
     /** EXEC CICS FORMATTIME's condition (IBM): INVREQ (16) RESP2 1 when the ABSTIME value is less than zero ("or not in
      *  packed-decimal format": the port reads the field by its declared usage). {resp, resp2}. */
     public static int[] formattimeCheck(long abstime) {
@@ -4554,6 +4629,8 @@ def commarea_alternative_todos(commarea: dict) -> list[str]:
     public static final class TempStorage {
         private final Map<String, List<byte[]>> queues = new LinkedHashMap<>();
         private final Map<String, Integer> next = new HashMap<>();
+        /** The intrapartition transient-data queues' records (#5079): first in first out. */
+        final Map<String, java.util.ArrayDeque<String>> td = new HashMap<>();
 
         /** A queue as it is before the conversation starts. */
         public TempStorage seed(String queue, List<byte[]> items) {

gitgalaxy/tools/cobol_to_java/det/cics.py

@@ -1228,6 +1228,12 @@ def command(self, text: str, ind: str) -> list[str]:
             return [f"{ind}int {r} = task.writeqTd({self.name(_arg(opts['QUEUE']))}, "
                     f"Cobol.text({f}, CS).substring(0, {n}));",
                     *self.outcome(opts, r, "0", ind)]  # fmt: skip
+        if verb == "DELETEQ TD":  # #5079 (X57): every record of an intrapartition queue
+            r = g.tmpname("resp")
+            return [f"{ind}int {r} = task.deleteqTd({self.name(_arg(opts['QUEUE']))});",
+                    *self.outcome(opts, r, "0", ind)]  # fmt: skip
+        if verb == "READQ TD":
+            return self.readq_td(opts, ind)
         if verb in ("WRITEQ TS", "WRITEQ", "READQ TS", "READQ", "DELETEQ TS", "DELETEQ") \
                 and verb.startswith(("WRITEQ", "READQ", "DELETEQ")) and "TD" not in words:  # fmt: skip
             return self.ts_queue(verb.split()[0], opts, ind)
@@ -2115,6 +2121,23 @@ def inquire_urimap(self, opts: dict, ind: str) -> list[str]:
             out.append(f"{ind}}}")
         return out + self.outcome(opts, f"{r}[0]", f"{r}[1]", ind)
 
+    def readq_td(self, opts: dict, ind: str) -> list[str]:
+        """#5079 (X57): READQ TD QUEUE INTO [LENGTH] -- a destructive read of the task's intrapartition queue. The record
+        goes INTO as the program's own text (a WRITEQ TD wrote it so); a record moved past INTO is refused at run time
+        (DetCics.readTd), as READ INTO's is. LENGTH(data-area) is set to the record's length on NORMAL and LENGERR."""
+        g = self.g
+        r = g.tmpname("td")
+        into = self.field(_arg(opts["INTO"]))
+        maxlen = self.int_(_arg(opts["LENGTH"])) if opts.get("LENGTH") else f"{into}.length()"
+        out = [
+            f"{ind}CicsTask.TdResult {r} = task.readqTd({self.name(_arg(opts['QUEUE']))}, {maxlen});",
+            f"{ind}if ({r}.data() != null) DetCics.readTd({into}, {r}.data().getBytes(CS));",
+        ]
+        if opts.get("LENGTH") and re.fullmatch(r"(?is)\d+|LENGTH\s+OF\s+.+", opts["LENGTH"].strip()) is None:
+            out.append(f"{ind}if ({r}.length() >= 0) Cobol.store({self.field(_arg(opts['LENGTH']))}, "
+                       f"BigDecimal.valueOf({r}.length()), false, CS);")  # fmt: skip
+        return out + self.outcome(opts, f"{r}.resp()", "0", ind)
+
     def ts_queue(self, verb: str, opts: dict, ind: str) -> list[str]:
         """WRITEQ TS / READQ TS on the task's temporary storage (CicsTask): an item is the program's own bytes in the
         region's code page (#4528: REGION, region_page) -- written from the storage's page (CS) and read back into

gitgalaxy/tools/cobol_to_java/det/cobolrt/cics/DetCics.java

@@ -364,6 +364,18 @@ public static int readInto(Field into, byte[] record, int max, boolean update) {
         return lengerr ? 22 : 0;
     }
 
+    /** #5079 (X57): READQ TD QUEUE INTO: the record's bytes (already cut to LENGTH) go INTO, the rest of INTO left as it
+     *  was. Refused, as not modelled, a record moved past INTO (CICS writes the storage that follows it, which GnuCOBOL
+     *  lays out unlike IBM's compiler: oracle_assumptions.md X6), as READ INTO's is. */
+    // [rule RT-CICS-READQ-TD-INTO]
+    public static void readTd(Field into, byte[] record) {
+        if (record.length > into.length()) {
+            throw new UnsupportedOperationException("READQ TD INTO LENGTH: " + record.length + " bytes past INTO's "
+                    + into.length() + ": not modelled");
+        }
+        System.arraycopy(record, 0, into.storage().bytes, into.offset(), record.length);
+    }
+
     /** #4415 slice 1: EXEC CICS BIF DEEDIT FIELD(f) LENGTH(n) (IBM CICS TS, "BIF DEEDIT"): the first `n` bytes of the
      *  field, as the region's EBCDIC page (`region`) holds them, edited in place -- the characters other than the
      *  digits X'F0'-X'F9' removed, the digits right-aligned and padded on the left with zeros; a field that ends in a