From 4a52232a69ba63919d04d6e8be8d487cfd26c245 Mon Sep 17 00:00:00 2001 From: squid-protocol Date: Fri, 16 Oct 2026 04:05:05 -0400 Subject: [PATCH 1/8] WIP: IMS DL/I runtime slice 1 -- CBLTDLI on both runtimes (Part of #4893) Co-Authored-By: Claude Opus 5.5 --- .../cobol_to_java/det/cobolrt/dli/DetDli.java | 846 ++++++++++++++++++ gitgalaxy/tools/cobol_to_java/det/dli.py | 59 ++ gitgalaxy/tools/cobol_to_java/det/gen.py | 5 + gitgalaxy/tools/cobol_to_java/det/program.py | 9 +- gitgalaxy/tools/cobol_to_java/det/stmt.py | 5 +- tests/equivalence/carddemo-paudbunl/LICENSE | 175 ++++ tests/equivalence/carddemo-paudbunl/NOTICE | 8 + tests/equivalence/carddemo-paudbunl/case.json | 51 ++ tests/equivalence/ims/ggdli.c | 682 ++++++++++++++ tests/tools/equivalence.py | 24 +- tests/tools/equivalence_ims.py | 318 +++++++ tests/tools/equivalence_java.py | 8 + 12 files changed, 2186 insertions(+), 4 deletions(-) create mode 100644 gitgalaxy/tools/cobol_to_java/det/cobolrt/dli/DetDli.java create mode 100644 gitgalaxy/tools/cobol_to_java/det/dli.py create mode 100644 tests/equivalence/carddemo-paudbunl/LICENSE create mode 100644 tests/equivalence/carddemo-paudbunl/NOTICE create mode 100644 tests/equivalence/carddemo-paudbunl/case.json create mode 100644 tests/equivalence/ims/ggdli.c create mode 100644 tests/tools/equivalence_ims.py diff --git a/gitgalaxy/tools/cobol_to_java/det/cobolrt/dli/DetDli.java b/gitgalaxy/tools/cobol_to_java/det/cobolrt/dli/DetDli.java new file mode 100644 index 0000000000..6fa1031805 --- /dev/null +++ b/gitgalaxy/tools/cobol_to_java/det/cobolrt/dli/DetDli.java @@ -0,0 +1,846 @@ +package __PACKAGE__.cobolrt.dli; + +import __PACKAGE__.cobolrt.Field; +import java.io.ByteArrayOutputStream; +import java.io.IOException; +import java.io.UncheckedIOException; +import java.nio.charset.StandardCharsets; +import java.nio.file.Files; +import java.nio.file.Path; +import java.util.ArrayList; +import java.util.Arrays; +import java.util.List; + +/** + * IMS DL/I database calls (#4893) for a batch DL/I program -- IMS enters its ENTRY 'DLITCBL' with its PCBs, and it + * issues CALL 'CBLTDLI' USING function pcb io-area [ssa ...]. The twin of the equivalence harness's COBOL-side model + * (tests/equivalence/ims/ggdli.c): the same rules and the same refusals, register family I + * (docs/language_status/register/I*.md); IBM's IMS Application Programming and IMS Messages and Codes ("DL/I status + * codes") are the reference. + * + * The database is stated, not connected: {@code gitgalaxy.dli.dir} holds dbd.cfg, psb.cfg and each database's seed + * (written by tests/tools/equivalence_ims.py from the DBD / PSB sources), and {@link #leave} writes each database to + * {@code gitgalaxy.dli.out}. Modelled: GU GHU GN GHN GNP GHNP ISRT REPL DLET through a DB PCB, unqualified SSAs and + * SSAs qualified by one field, status blank GA GK GE GB GP II DJ DA AC AJ AK AD AM; anything else stops the run by + * name (UnsupportedOperationException "CBLTDLI: ... is not modelled"). + */ +public final class DetDli { + private DetDli() { + } + + private static final class Segm { + String name; + int db; + int parent; + int bytes; + int level; + int key = -1; + } + + private static final class Fld { + String name; + int seg; + int start; + int bytes; + char type; + } + + private static final class Node { + int seg; + byte[] data; + Node parent; + final List kids = new ArrayList<>(); + } + + private static final int POS_START = 0; + private static final int POS_AT = 1; + private static final int POS_UNKNOWN = 2; + private static final int PAR_NONE = 0; + private static final int PAR_AT = 1; + private static final int PAR_UNKNOWN = 2; + + private static final class Pcb { + int db; + int keylen; + int sensegs; + String procopt; + Field mask; + int pos = POS_START; + Node at; + int par = PAR_NONE; + Node parentage; + Node hold; + boolean prevknown; + } + + private static final class Ssa { + int seg; + int fld = -1; + int op; + byte[] value; + } + + private static final List SEGS = new ArrayList<>(); + private static final List FLDS = new ArrayList<>(); + private static final List DBS = new ArrayList<>(); + private static final List ROOTS = new ArrayList<>(); // per database, a virtual node over its roots + private static final List PCBS = new ArrayList<>(); + + private static UnsupportedOperationException refuse(String what) { + return new UnsupportedOperationException("CBLTDLI: " + what + " is not modelled"); + } + + private static Path dir() { + String d = System.getProperty("gitgalaxy.dli.dir"); + if (d == null) { + throw refuse("a run with no database stated (gitgalaxy.dli.dir)"); + } + return Path.of(d); + } + + private static String name8(byte[] b, int at) { + return new String(b, at, 8, StandardCharsets.ISO_8859_1).replaceAll(" +$", ""); + } + + private static int findSeg(int db, String name) { + for (int i = 0; i < SEGS.size(); i++) { + if (SEGS.get(i).db == db && SEGS.get(i).name.equals(name)) { + return i; + } + } + return -1; + } + + private static int findFld(int seg, String name) { + for (int i = 0; i < FLDS.size(); i++) { + if (FLDS.get(i).seg == seg && FLDS.get(i).name.equals(name)) { + return i; + } + } + return -1; + } + + private static int keyCmp(Node a, byte[] b, int at) { + Fld k = FLDS.get(SEGS.get(a.seg).key); + return Arrays.compareUnsigned(a.data, k.start - 1, k.start - 1 + k.bytes, b, at, at + k.bytes); + } + + private static int keyAt(Node n) { + return FLDS.get(SEGS.get(n.seg).key).start - 1; + } + + /** A child in its place: after the twins of earlier segment types (DBD order), among its own in key order. */ + private static void linkChild(Node parent, Node n) { + int i = 0; + while (i < parent.kids.size()) { + Node c = parent.kids.get(i); + if (c.seg > n.seg || (c.seg == n.seg && keyCmp(c, n.data, keyAt(n)) >= 0)) { + break; + } + i++; + } + parent.kids.add(i, n); + n.parent = parent; + } + + // [rule RT-DLI-STATE] + private static void load() throws IOException { + SEGS.clear(); + FLDS.clear(); + DBS.clear(); + ROOTS.clear(); + PCBS.clear(); + for (String line : Files.readAllLines(dir().resolve("dbd.cfg"), StandardCharsets.ISO_8859_1)) { + String[] w = line.trim().split("\\s+"); + if (w[0].equals("DBD")) { + DBS.add(w[1]); + Node root = new Node(); + root.seg = -1; + ROOTS.add(root); + } else if (w[0].equals("SEGM")) { + Segm s = new Segm(); + s.db = DBS.size() - 1; + s.name = w[2]; + s.bytes = Integer.parseInt(w[4]); + s.parent = w[3].equals("0") ? -1 : findSeg(s.db, w[3]); + s.level = s.parent < 0 ? 1 : SEGS.get(s.parent).level + 1; + SEGS.add(s); + } else if (w[0].equals("FIELD")) { + Fld f = new Fld(); + f.seg = findSeg(DBS.size() - 1, w[2]); + f.name = w[3]; + f.start = Integer.parseInt(w[4]); + f.bytes = Integer.parseInt(w[5]); + f.type = w[6].charAt(0); + if (w[7].equals("S")) { + SEGS.get(f.seg).key = FLDS.size(); + } + FLDS.add(f); + } + } + for (Segm s : SEGS) { + if (s.key < 0) { + throw refuse("a segment with no sequence field"); + } + } + for (int d = 0; d < DBS.size(); d++) { + loadDb(d); + } + } + + private static void loadDb(int d) throws IOException { + Path seed = dir().resolve("seed." + DBS.get(d)); + if (!Files.exists(seed)) { + return; // no seed: an empty database + } + byte[] b = Files.readAllBytes(seed); + Node[] last = new Node[SEGS.size()]; + int i = 0; + while (i + 8 <= b.length) { + int s = findSeg(d, name8(b, i)); + if (s < 0) { + throw refuse("a seed segment the DBD does not define"); + } + Segm sg = SEGS.get(s); + if (i + 8 + sg.bytes > b.length) { + throw refuse("a truncated seed"); + } + Node n = new Node(); + n.seg = s; + n.data = Arrays.copyOfRange(b, i + 8, i + 8 + sg.bytes); + i += 8 + sg.bytes; + Node parent = sg.parent < 0 ? ROOTS.get(d) : last[sg.parent]; + if (parent == null) { + throw refuse("a seed segment before its parent"); + } + if (!parent.kids.isEmpty()) { + Node prev = parent.kids.get(parent.kids.size() - 1); + if (prev.seg > s || (prev.seg == s && keyCmp(prev, n.data, keyAt(n)) >= 0)) { + throw refuse("a seed not in hierarchic sequence (twins in byte order of their keys)"); + } + } + n.parent = parent; + parent.kids.add(n); + last[s] = n; + for (int c = 0; c < SEGS.size(); c++) { + if (SEGS.get(c).db == d && SEGS.get(c).level > sg.level) { + last[c] = null; + } + } + } + } + + private static void fullword(Field mask, int at, int v) { + byte[] b = mask.storage().bytes; + int o = mask.offset() + at; + b[o] = (byte) (v >> 24); + b[o + 1] = (byte) (v >> 16); + b[o + 2] = (byte) (v >> 8); + b[o + 3] = (byte) v; + } + + private static void text(Field mask, int at, int len, String s) { + byte[] b = mask.storage().bytes; + int o = mask.offset() + at; + Arrays.fill(b, o, o + len, (byte) ' '); + byte[] t = s.getBytes(StandardCharsets.ISO_8859_1); + System.arraycopy(t, 0, b, o, Math.min(t.length, len)); + } + + /** + * The batch entry (ENTRY 'DLITCBL' USING pcb ...): the stated databases loaded, each DB PCB of the PSB (in order) + * bound to the area passed, its mask filled -- DBD name, level '00', status blank, PROCOPT, the number of + * sensitive segments, key feedback length 0 (register I4). + */ + // [rule RT-DLI-ENTRY] + public static void enter(Field... areas) { + try { + load(); + for (String line : Files.readAllLines(dir().resolve("psb.cfg"), StandardCharsets.ISO_8859_1)) { + String[] w = line.trim().split("\\s+"); + if (!w[0].equals("PCB")) { + continue; + } + Pcb p = new Pcb(); + p.db = DBS.indexOf(w[1]); + p.procopt = w[2].length() > 4 ? w[2].substring(0, 4) : w[2]; + p.keylen = Integer.parseInt(w[3]); + for (Segm s : SEGS) { + if (s.db == p.db) { + p.sensegs++; + } + } + PCBS.add(p); + } + } catch (IOException e) { + throw new UncheckedIOException(e); + } + if (areas.length != PCBS.size()) { + throw refuse("an entry whose USING does not list one area per PCB of the PSB"); + } + for (int i = 0; i < areas.length; i++) { + Pcb p = PCBS.get(i); + p.mask = areas[i]; + if (p.mask.length() < 36 + p.keylen) { + throw refuse("a PCB mask shorter than the PCB (36 bytes and the KEYLEN)"); + } + byte[] b = p.mask.storage().bytes; + int o = p.mask.offset(); + Arrays.fill(b, o, o + 36, (byte) ' '); + text(p.mask, 0, 8, DBS.get(p.db)); + text(p.mask, 8, 2, "00"); + text(p.mask, 12, 4, p.procopt); + fullword(p.mask, 16, 0); + fullword(p.mask, 28, 0); + fullword(p.mask, 32, p.sensegs); + // the key feedback area, and the bytes past it the program's mask may name: X'00' (register I4) + Arrays.fill(b, o + 36, o + p.mask.length(), (byte) 0); + } + } + + /** The step ended: each database, in hierarchic sequence (8-byte segment name, then its data), to gitgalaxy.dli.out. */ + // [rule RT-DLI-STATE] + public static void leave() { + String out = System.getProperty("gitgalaxy.dli.out"); + if (out == null) { + return; + } + try { + for (int d = 0; d < DBS.size(); d++) { + ByteArrayOutputStream o = new ByteArrayOutputStream(); + dump(o, ROOTS.get(d)); + Files.write(Path.of(out).resolve(DBS.get(d) + ".out"), o.toByteArray()); + } + } catch (IOException e) { + throw new UncheckedIOException(e); + } + } + + private static void dump(ByteArrayOutputStream o, Node n) { + for (Node c : n.kids) { + byte[] nm = new byte[8]; + Arrays.fill(nm, (byte) ' '); + byte[] t = SEGS.get(c.seg).name.getBytes(StandardCharsets.ISO_8859_1); + System.arraycopy(t, 0, nm, 0, t.length); + o.writeBytes(nm); + o.writeBytes(c.data); + dump(o, c); + } + } + + // ---- the hierarchic sequence -------------------------------------------------------------------------------- + private static Node nextInSeq(Node n) { + if (!n.kids.isEmpty()) { + return n.kids.get(0); + } + while (n.parent != null) { + List sib = n.parent.kids; + int i = sib.indexOf(n); + if (i + 1 < sib.size()) { + return sib.get(i + 1); + } + n = n.parent; + } + return null; + } + + private static Node dbFirst(int d) { + List k = ROOTS.get(d).kids; + return k.isEmpty() ? null : k.get(0); + } + + private static boolean descends(Node n, Node anc) { + for (Node p = n.parent; p != null; p = p.parent) { + if (p == anc) { + return true; + } + } + return false; + } + + private static boolean descendsType(int t, int anc) { + for (; t >= 0; t = SEGS.get(t).parent) { + if (t == anc) { + return true; + } + } + return false; + } + + private static Node lastInSubtree(Node n) { + while (!n.kids.isEmpty()) { + n = n.kids.get(n.kids.size() - 1); + } + return n; + } + + private static Node ancestorOfType(Node n, int seg) { + for (; n != null && n.parent != null; n = n.parent) { + if (n.seg == seg) { + return n; + } + } + return null; + } + + // ---- SSAs --------------------------------------------------------------------------------------------------- + private static final String[][] OPS = {{"EQ", " =", "= "}, {"GT", " >", "> "}, {"LT", " <", "< "}, + {"GE", ">=", "=>"}, {"LE", "<=", "=<"}, {"NE", "¬=", "=¬"}}; + + /** The SSAs of a call; a status code that rejects them is returned in st[0]. */ + // [rule RT-DLI-SSA] + private static Ssa[] parseSsas(int db, Field[] raw, String[] st) { + Ssa[] out = new Ssa[raw.length]; + for (int i = 0; i < raw.length; i++) { + byte[] b = raw[i].storage().bytes; + int o = raw[i].offset(); + Ssa s = new Ssa(); + out[i] = s; + s.seg = findSeg(db, name8(b, o)); + if (s.seg < 0) { + st[0] = "AC"; + return out; + } + int q = b[o + 8] & 0xFF; + if (q == ' ') { + continue; + } + if (q == '*') { + throw refuse("an SSA with command codes"); + } + if (q != '(') { + st[0] = "AJ"; + return out; + } + s.fld = findFld(s.seg, name8(b, o + 9)); + if (s.fld < 0) { + st[0] = "AK"; + return out; + } + String op = new String(b, o + 17, 2, StandardCharsets.ISO_8859_1); + s.op = -1; + for (int k = 0; k < OPS.length; k++) { + for (String v : OPS[k]) { + if (v.equals(op)) { + s.op = k; + } + } + } + if (s.op < 0) { + st[0] = "AJ"; + return out; + } + Fld f = FLDS.get(s.fld); + s.value = Arrays.copyOfRange(b, o + 19, o + 19 + f.bytes); + int end = b[o + 19 + f.bytes] & 0xFF; + if (end == '&' || end == '*' || end == '+' || end == '|' || end == '#') { + throw refuse("a boolean SSA qualification"); + } + if (end != ')') { + st[0] = "AJ"; + return out; + } + if (f.type != 'C' && f.type != 'X' && f.type != 'P') { + throw refuse("a qualification on a field of a type other than C, X or P"); + } + } + return out; + } + + private static int packedSign(byte[] p, int at, int n) { + for (int i = 0; i < n; i++) { + int v = p[at + i] & 0xFF; + if ((v >> 4) > 9 || (i < n - 1 && (v & 15) > 9)) { + return -1; + } + } + return p[at + n - 1] & 15; + } + + // [rule RT-DLI-QUALIFY] + private static boolean qualifies(Node n, Ssa s) { + if (s.fld < 0) { + return true; + } + Fld f = FLDS.get(s.fld); + if (f.type == 'P') { + int sa = packedSign(n.data, f.start - 1, f.bytes); + int sb = packedSign(s.value, 0, f.bytes); + if (sa < 0 || sb < 0 || sa != sb || (sa != 0xC && sa != 0xF)) { + throw refuse("a P-field qualification on operands that are not both valid with one positive sign"); + } + } + int c = Arrays.compareUnsigned(n.data, f.start - 1, f.start - 1 + f.bytes, s.value, 0, f.bytes); + switch (s.op) { + case 0: return c == 0; + case 1: return c > 0; + case 2: return c < 0; + case 3: return c >= 0; + case 4: return c <= 0; + default: return c != 0; + } + } + + private static boolean satisfies(Node n, Ssa[] s, int k) { + if (k == 0) { + return true; + } + if (n.seg != s[k - 1].seg) { + return false; + } + for (int i = 0; i < k; i++) { + Node a = ancestorOfType(n, s[i].seg); + if (a == null || !qualifies(a, s[i])) { + return false; + } + } + return true; + } + + /** SSAs in hierarchic order, each the child of the one before: null, "AC", or a refusal. */ + private static String chain(Ssa[] s, int k) { + for (int i = 1; i < k; i++) { + int p = SEGS.get(s[i].seg).parent; + if (p == s[i - 1].seg) { + continue; + } + while (p >= 0 && p != s[i - 1].seg) { + p = SEGS.get(p).parent; + } + if (p < 0) { + return "AC"; + } + throw refuse("SSAs that leave out an intermediate level"); + } + return null; + } + + // ---- the PCB mask ------------------------------------------------------------------------------------------- + private static void status(Pcb p, String st) { + text(p.mask, 10, 2, st); + } + + // [rule RT-DLI-FEEDBACK] + private static void feedback(Pcb p, Node n) { + if (n == null || n.parent == null) { + text(p.mask, 8, 2, "00"); + text(p.mask, 20, 8, ""); + fullword(p.mask, 28, 0); + return; + } + Segm sg = SEGS.get(n.seg); + text(p.mask, 8, 2, String.format(java.util.Locale.ROOT, "%02d", sg.level)); + text(p.mask, 20, 8, sg.name); + List path = new ArrayList<>(); + for (Node a = n; a != null && a.parent != null; a = a.parent) { + path.add(0, a); + } + byte[] b = p.mask.storage().bytes; + int len = 0; + for (Node a : path) { + Fld k = FLDS.get(SEGS.get(a.seg).key); + if (len + k.bytes > p.keylen) { + throw refuse("a concatenated key longer than the PCB's KEYLEN"); + } + System.arraycopy(a.data, k.start - 1, b, p.mask.offset() + 36 + len, k.bytes); + len += k.bytes; + } + fullword(p.mask, 28, len); + } + + private static boolean allows(Pcb p, char what) { + return p.procopt.indexOf('A') >= 0 || p.procopt.indexOf(what) >= 0; + } + + private static Pcb findPcb(Field mask) { + for (Pcb p : PCBS) { + if (p.mask.storage() == mask.storage() && p.mask.offset() == mask.offset()) { + return p; + } + } + throw refuse("a PCB the program was not passed"); + } + + private static Node firstSatisfying(Node from, Node bound, Ssa[] s, int k) { + for (Node c = from; c != null; c = nextInSeq(c)) { + if (bound != null && !descends(c, bound)) { + return null; + } + if (satisfies(c, s, k)) { + return c; + } + } + return null; + } + + /** The deepest segment along the SSAs' path that IMS could satisfy (the feedback of an unsuccessful call). */ + private static Node deepest(int db, Ssa[] s, int upto) { + for (int j = upto; j >= 1; j--) { + Node c = firstSatisfying(dbFirst(db), null, s, j); + if (c != null) { + return c; + } + } + return null; + } + + /** GU / GN / GNP and their holds. */ + // [rule RT-DLI-GET] + private static void get(Pcb p, String fn, Field io, Ssa[] s, boolean hold) { + int k = s.length; + if (!allows(p, 'G')) { + status(p, "AM"); + return; + } + if (hold && p.procopt.indexOf('O') >= 0) { + throw refuse("a get-hold call under PROCOPT O"); + } + String bad = chain(s, k); + if (bad != null) { + status(p, bad); + return; + } + boolean gu = fn.charAt(1) == 'U' || fn.charAt(2) == 'U'; + boolean gnp = !gu && fn.contains("NP"); + Node from; + Node bound = null; + if (gu) { + if (k > 0 && SEGS.get(s[0].seg).parent >= 0) { + throw refuse("a GU whose SSAs leave out the root level"); + } + from = dbFirst(p.db); + } else { + if (gnp) { + if (p.par == PAR_NONE) { + status(p, "GP"); + return; + } + if (p.par == PAR_UNKNOWN) { + throw refuse("a GNP after a call that leaves parentage open"); + } + bound = p.parentage; + if (k > 0 && !descendsType(SEGS.get(s[0].seg).parent, bound.seg)) { + throw refuse("a GNP whose SSAs name a segment outside its parent"); + } + } + if (p.pos == POS_UNKNOWN) { + throw refuse("a GN / GNP after a call that leaves position open"); + } + if (bound != null && (p.pos != POS_AT || (p.at != bound && !descends(p.at, bound)))) { + throw refuse("a GNP whose position is outside its parent"); + } + from = p.pos == POS_START ? dbFirst(p.db) : nextInSeq(p.at); + } + Node n = firstSatisfying(from, bound, s, k); + if (n == null) { + boolean qualified = false; + for (Ssa x : s) { + qualified |= x.fld >= 0; + } + if (gu) { + status(p, "GE"); + feedback(p, deepest(p.db, s, k - 1)); + p.pos = POS_UNKNOWN; + p.par = PAR_UNKNOWN; + } else if (gnp) { + if (qualified) { + throw refuse("a qualified GNP that finds nothing (where IMS leaves position)"); + } + status(p, "GE"); + feedback(p, bound); + p.pos = POS_AT; + p.at = lastInSubtree(bound); + p.prevknown = false; + } else { + if (qualified) { + throw refuse("a qualified GN that finds nothing (GE or GB: IMS's sequence-field search)"); + } + status(p, "GB"); + p.pos = POS_START; + p.prevknown = false; + } + return; + } + String st = " "; + if (!gu && k == 0 && p.prevknown && p.pos == POS_AT) { + int was = SEGS.get(p.at.seg).level; + int now = SEGS.get(n.seg).level; + if (now < was) { + st = "GA"; + } else if (now == was && n.seg != p.at.seg) { + st = "GK"; + } + } + if (io.storage().bytes.length - io.offset() < n.data.length) { + throw refuse("an I/O area shorter than the segment"); + } + System.arraycopy(n.data, 0, io.storage().bytes, io.offset(), n.data.length); + status(p, st); + feedback(p, n); + p.pos = POS_AT; + p.at = n; + p.prevknown = true; + if (!gnp) { + p.par = PAR_AT; + p.parentage = n; + } + if (hold) { + p.hold = n; + } + } + + /** ISRT: the last SSA names the type inserted; the SSAs before it locate the parent from the root, or current + * position does. */ + // [rule RT-DLI-ISRT] + private static void isrt(Pcb p, Field io, Ssa[] s) { + int k = s.length; + if (!allows(p, 'I')) { + status(p, "AM"); + return; + } + if (k == 0) { + throw refuse("an ISRT with no SSA"); + } + if (s[k - 1].fld >= 0) { + throw refuse("an ISRT whose last SSA is qualified"); + } + String bad = chain(s, k); + if (bad != null) { + status(p, bad); + return; + } + int t = s[k - 1].seg; + Segm sg = SEGS.get(t); + Node parent; + if (sg.parent < 0) { + if (k > 1) { + throw refuse("an ISRT of a root with SSAs before it"); + } + parent = ROOTS.get(p.db); + } else if (k == 1) { + if (p.pos != POS_AT) { + throw refuse("an ISRT that relies on a position left open"); + } + parent = ancestorOfType(p.at, sg.parent); + if (parent == null) { + throw refuse("an ISRT whose parent is not on the current position's path"); + } + } else { + if (SEGS.get(s[0].seg).parent >= 0) { + throw refuse("an ISRT whose SSAs leave out the root level"); + } + parent = firstSatisfying(dbFirst(p.db), null, s, k - 1); + if (parent == null) { + status(p, "GE"); + feedback(p, deepest(p.db, s, k - 2)); + p.pos = POS_UNKNOWN; + p.par = PAR_UNKNOWN; + return; + } + } + byte[] b = io.storage().bytes; + int key = io.offset() + FLDS.get(sg.key).start - 1; + for (Node c : parent.kids) { + if (c.seg == t && keyCmp(c, b, key) == 0) { + status(p, "II"); + feedback(p, parent.parent != null ? parent : null); + p.pos = POS_UNKNOWN; + p.par = PAR_UNKNOWN; + return; + } + } + Node n = new Node(); + n.seg = t; + n.data = Arrays.copyOfRange(b, io.offset(), io.offset() + sg.bytes); + linkChild(parent, n); + status(p, " "); + feedback(p, n); + p.pos = POS_AT; + p.at = n; + p.prevknown = false; + p.par = PAR_UNKNOWN; + } + + /** REPL / DLET: on the segment the previous call on this PCB held. */ + // [rule RT-DLI-CHANGE] + private static void change(Pcb p, boolean dlet, Field io, Node held, int k) { + if (!allows(p, dlet ? 'D' : 'R')) { + status(p, "AM"); + return; + } + if (k > 0) { + throw refuse(dlet ? "a DLET with SSAs" : "a REPL with SSAs"); + } + if (held == null) { + status(p, "DJ"); + return; + } + byte[] b = io.storage().bytes; + if (keyCmp(held, b, io.offset() + keyAt(held)) != 0) { + status(p, "DA"); + return; + } + status(p, " "); + if (!dlet) { + System.arraycopy(b, io.offset(), held.data, 0, held.data.length); + return; + } + Node prev = null; + for (Node c = dbFirst(p.db); c != null && c != held; c = nextInSeq(c)) { + prev = c; + } + held.parent.kids.remove(held); + for (Pcb o : PCBS) { + if (o != p && o.db == p.db && o.pos == POS_AT && (o.at == held || descends(o.at, held))) { + o.pos = POS_UNKNOWN; + } + if (o.par == PAR_AT && (o.parentage == held || descends(o.parentage, held))) { + o.par = PAR_UNKNOWN; + } + } + p.pos = prev != null ? POS_AT : POS_START; + p.at = prev; + p.prevknown = false; + } + + private static final List KNOWN = List.of("GU ", "GHU ", "GN ", "GHN ", "GNP ", "GHNP", "ISRT", "REPL", + "DLET"); + private static final List OTHER = List.of("CHKP", "XRST", "ROLB", "ROLL", "ROLS", "SETS", "SETU", "SYNC", + "LOG ", "STAT", "GSCD", "FLD ", "POS ", "INIT", "INQY", "SNAP", "PCB ", "TERM", "GMSG", "ICMD", "RCMD", "CMD ", + "GCMD", "AUTH", "CHNG", "PURG", "DEQ ", "SETO", "APSB", "DPSB", "GSTA"); + + /** CALL 'CBLTDLI' USING function pcb io-area [ssa ...]. */ + // [rule RT-DLI-CALL] + public static void call(Field function, Field pcb, Field io, Field... ssas) { + if (PCBS.isEmpty()) { + throw refuse("a call before the program's DL/I entry"); + } + Pcb p = findPcb(pcb); + String fn = new String(function.storage().bytes, function.offset(), 4, StandardCharsets.ISO_8859_1); + Node held = p.hold; + p.hold = null; + if (!KNOWN.contains(fn)) { + if (OTHER.contains(fn)) { + throw refuse("a DL/I call other than GU GHU GN GHN GNP GHNP ISRT REPL DLET"); + } + status(p, "AD"); + return; + } + if (ssas.length > 15) { + throw refuse("more than 15 SSAs"); + } + String[] st = new String[1]; + Ssa[] s = parseSsas(p.db, ssas, st); + if (st[0] != null) { + status(p, st[0]); + return; + } + if (fn.charAt(0) == 'G') { + get(p, fn, io, s, fn.charAt(1) == 'H'); + } else if (fn.equals("ISRT")) { + isrt(p, io, s); + } else { + change(p, fn.charAt(0) == 'D', io, held, s.length); + } + } +} diff --git a/gitgalaxy/tools/cobol_to_java/det/dli.py b/gitgalaxy/tools/cobol_to_java/det/dli.py new file mode 100644 index 0000000000..957fc0d24c --- /dev/null +++ b/gitgalaxy/tools/cobol_to_java/det/dli.py @@ -0,0 +1,59 @@ +"""IMS DL/I database calls in a det port (#4893): a batch DL/I program -- IMS enters its ENTRY 'DLITCBL' USING its +PCBs -- and its CALL 'CBLTDLI' USING function pcb io-area [ssa ...], each run by the det runtime's DetDli +(cobolrt/dli/DetDli.java), the twin of the equivalence harness's COBOL-side model (tests/equivalence/ims/ggdli.c). +Register family I states the model; what it does not model is refused here by name, or stops the run by name there. + + DetDli.enter(pcb-1, ..., pcb-n) the program's entry (runBatch): binds the PSB's DB PCBs + DetDli.call(function, pcb, io, ssa ...) each CALL 'CBLTDLI'; RETURN-CODE 0 after it (register I1) + DetDli.leave() the step ended: the databases written for the comparison +""" + +from __future__ import annotations + +from typing import Any + +from gitgalaxy.tools.cobol_to_java.det import expr as E +from gitgalaxy.tools.cobol_to_java.det import stmt as S + +ENTRY = "DLITCBL" # IMS's entry name for a DL/I program written in COBOL +CALL = "CBLTDLI" +# the other DL/I language interfaces: refused by name (CBLTDLI's call through an AIB, LE's CEETDLI) +REFUSED_BY_NAME = { + "AIBTDLI": "CALL AIBTDLI: the DL/I call through an AIB (application interface block) is not modelled", + "CEETDLI": "CALL CEETDLI: the Language Environment DL/I interface is not modelled", +} +BINARY = {"COMP", "COMP-4", "COMP-5", "BINARY", "COMPUTATIONAL", "COMPUTATIONAL-4", "COMPUTATIONAL-5"} + + +def entry_pcbs(proc: S.Procedure) -> list[str] | None: + """The PCB names of a program IMS enters at ENTRY 'DLITCBL' (its first statement, stmt._entry), else None.""" + first = next((p.body[0] for p in proc.paragraphs if p.body), None) + if first is None or first.kind != "ENTRY" or not first.data.get("first") or first.data["name"].upper() != ENTRY: + return None + return [r.name.upper() for r in first.data["using"]] + + +def call(gen: Any, s: S.Stmt, ind: str) -> list[str]: + """CALL 'CBLTDLI' USING function pcb io-area [ssa-1 ... ssa-15]: DetDli.call, then RETURN-CODE 0.""" + from gitgalaxy.tools.cobol_to_java.det.gen import Untranslatable + + pcbs = getattr(gen, "dli_pcbs", None) + if pcbs is None: + raise Untranslatable(f"CALL {CALL}: a program IMS does not enter at ENTRY '{ENTRY}' (BMP, MPP or CICS) " + "is not modelled") # fmt: skip + args = s.data["args"] + if s.phrases: + raise Untranslatable(f"CALL {CALL}: ON EXCEPTION / OVERFLOW phrases are not modelled") + if not 3 <= len(args) <= 18: + raise Untranslatable(f"CALL {CALL}: a function, a PCB, an I/O area and up to 15 SSAs expected") + if any(m != "REFERENCE" or not isinstance(a, E.Ref) for m, a in args): + raise Untranslatable(f"CALL {CALL}: items BY REFERENCE expected") + refs = [a for _, a in args] + first = gen.resolve(refs[0]) + if (getattr(first, "usage", None) or "").upper() in BINARY: + raise Untranslatable(f"CALL {CALL}: the parameter-count form (a binary count first) is not modelled") + if refs[1].name.upper() not in pcbs or refs[1].subscripts or refs[1].refmod is not None: + raise Untranslatable(f"CALL {CALL}: the PCB {refs[1].name} is not one IMS passed at ENTRY '{ENTRY}'") + fields = ", ".join(gen.field_expr(r) for r in refs) + rc = gen.field_expr(E.Ref("RETURN-CODE")) + return [f"{ind}DetDli.call({fields});", f"{ind}Cobol.store({rc}, BigDecimal.ZERO, false, CS);"] diff --git a/gitgalaxy/tools/cobol_to_java/det/gen.py b/gitgalaxy/tools/cobol_to_java/det/gen.py index d868ffef7f..85d08d1bbc 100644 --- a/gitgalaxy/tools/cobol_to_java/det/gen.py +++ b/gitgalaxy/tools/cobol_to_java/det/gen.py @@ -14,6 +14,7 @@ from pathlib import Path from typing import TYPE_CHECKING, Any +from gitgalaxy.tools.cobol_to_java.det import dli from gitgalaxy.tools.cobol_to_java.det import expr as E from gitgalaxy.tools.cobol_to_java.det import layout as L from gitgalaxy.tools.cobol_to_java.det import osvs as O @@ -2666,6 +2667,10 @@ def call(self, s: S.Stmt, ind: str) -> list[str]: f"{ind}Cobol.store({self.field_expr(E.Ref('RETURN-CODE'))}, BigDecimal.valueOf({rc}), false, CS);" ) return out + if prog in ("CBLTDLI", *dli.REFUSED_BY_NAME): # #4893: IMS DL/I (det/dli.py, register family I) + if prog != "CBLTDLI": + raise Untranslatable(dli.REFUSED_BY_NAME[prog]) + return dli.call(self, s, ind) lib = LIBRARY.get(prog) if lib is not None: if len(args) != lib[1] or any(m != "REFERENCE" or not isinstance(a, E.Ref) for m, a in args): diff --git a/gitgalaxy/tools/cobol_to_java/det/program.py b/gitgalaxy/tools/cobol_to_java/det/program.py index 4e0a292570..77532584a5 100644 --- a/gitgalaxy/tools/cobol_to_java/det/program.py +++ b/gitgalaxy/tools/cobol_to_java/det/program.py @@ -19,6 +19,7 @@ from gitgalaxy.core.aperture import DET_PORT_MARKER from gitgalaxy.tools.cobol_to_java.det import bll as B from gitgalaxy.tools.cobol_to_java.det import cics as C +from gitgalaxy.tools.cobol_to_java.det import dli as DLI from gitgalaxy.tools.cobol_to_java.det import dyncall from gitgalaxy.tools.cobol_to_java.det import expr as E from gitgalaxy.tools.cobol_to_java.det import gen as G @@ -634,6 +635,7 @@ def _translate(program: Path, copy_dirs: list[Path], stub: str, package: str, es gen.alphabets, gen.program_collating = alphabets(lines) _pcs_figuratives(records, gen) gen.copy_dirs = [program.parent, *copy_dirs, C.COPY] + gen.dli_pcbs = None if is_cics else DLI.entry_pcbs(proc) # #4893: IMS enters it at ENTRY 'DLITCBL' (det/dli.py) gen.engine = engine gen.java_root = (project / "src/main/java") if project is not None else None gen.clock = "clock.currentDate()" if batch else "Funcs.currentDate(java.time.LocalDateTime.now())" @@ -882,7 +884,10 @@ def callee_types(cls: str) -> list[str]: extra_imports: list[str] = [] using = [u for u in proc.using if u != "BY"] parm_code = [] - if using: + if gen.dli_pcbs is not None: # #4893: IMS passes the PSB's PCBs, no PARM (DFSRRC00's PARM is IMS's own) + parm_code = [f" DetDli.enter({', '.join(gen.field_expr(E.Ref(n)) for n in gen.dli_pcbs)});"] + extra_imports.append(f"{package}.cobolrt.dli.DetDli") + elif using: u0 = next((r for r in linkage if r.name == using[0]), None) if u0 is not None: st = _storage_name(roots[id(u0)]) @@ -1225,6 +1230,8 @@ def callee_types(cls: str) -> list[str]: " } catch (Goback g) {", " // the program ended", " }", + *([" DetDli.leave(); // the step ended: its databases, as it left them"] + if gen.dli_pcbs is not None else []), f" return Cobol.num({gen.ids[id(rc)]}, CS).intValue();", " }", "", diff --git a/gitgalaxy/tools/cobol_to_java/det/stmt.py b/gitgalaxy/tools/cobol_to_java/det/stmt.py index b9a2cbfc1e..68d67e13f5 100644 --- a/gitgalaxy/tools/cobol_to_java/det/stmt.py +++ b/gitgalaxy/tools/cobol_to_java/det/stmt.py @@ -363,9 +363,10 @@ def node_text(n) -> str: if not paragraphs[0].body: paragraphs.pop(0) first = next((p.body[0] for p in paragraphs if p.body), None) - if first is not None and first.kind == "ENTRY" and not using: + if first is not None and first.kind == "ENTRY" and (not using or first.data["name"].upper() == "DLITCBL"): # #4462: the program's first statement (DL/I's ENTRY 'DLITCBL' USING pcb ...): where the caller enters it, - # with those parameters, as PROCEDURE DIVISION USING would; reached in sequence, ENTRY does nothing + # with those parameters, as PROCEDURE DIVISION USING would; reached in sequence, ENTRY does nothing. + # #4893: IMS enters a DL/I program at DLITCBL even when PROCEDURE DIVISION has a USING of its own first.data["first"] = True using = [r.name for r in first.data["using"]] return Procedure(paragraphs, execs, using) diff --git a/tests/equivalence/carddemo-paudbunl/LICENSE b/tests/equivalence/carddemo-paudbunl/LICENSE new file mode 100644 index 0000000000..67db858821 --- /dev/null +++ b/tests/equivalence/carddemo-paudbunl/LICENSE @@ -0,0 +1,175 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. diff --git a/tests/equivalence/carddemo-paudbunl/NOTICE b/tests/equivalence/carddemo-paudbunl/NOTICE new file mode 100644 index 0000000000..8657b7a728 --- /dev/null +++ b/tests/equivalence/carddemo-paudbunl/NOTICE @@ -0,0 +1,8 @@ +Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + +This case is derived from the AWS Mainframe Modernization CardDemo application +(https://github.com/aws-samples/aws-mainframe-modernization-carddemo), licensed under the Apache License, Version 2.0 +(LICENSE here): the program under test (app/app-authorization-ims-db2-mq/cbl/PAUDBUNL.CBL), its copybooks +(CIPAUSMY, CIPAUDTY, PAUTBPCB, IMSFUNCS), the DBD (ims/DBPAUTP0.dbd), the PSB (ims/PAUTBUNL.PSB) and the database's +unload (data/EBCDIC/AWS.M2.CARDDEMO.IMSDATA.DBPAUTP0.dat) are CardDemo's, used unmodified. Nothing in this case is +written for it but case.json. diff --git a/tests/equivalence/carddemo-paudbunl/case.json b/tests/equivalence/carddemo-paudbunl/case.json new file mode 100644 index 0000000000..de230effb3 --- /dev/null +++ b/tests/equivalence/carddemo-paudbunl/case.json @@ -0,0 +1,51 @@ +{ + "corpus": "aws-mainframe-modernization-carddemo", + "program": "PAUDBUNL", + "program_source": "app/app-authorization-ims-db2-mq/cbl/PAUDBUNL.CBL", + "copy_dirs": [ + "app/app-authorization-ims-db2-mq/cpy" + ], + "job": "UNLDPADB", + "step": "STEP01", + "parm": null, + "clock": "2022/10/07 10:30:15.00", + "datasets": { + "OUTFIL1": { + "reclen": 100, + "compare": true, + "copybook": "app/app-authorization-ims-db2-mq/cbl/PAUDBUNL.CBL", + "record": "OPFIL1-REC" + }, + "OUTFIL2": { + "reclen": 206, + "compare": true, + "copybook": "app/app-authorization-ims-db2-mq/cbl/PAUDBUNL.CBL", + "record": "OPFIL2-REC" + } + }, + "ims": { + "dbd": [ + "app/app-authorization-ims-db2-mq/ims/DBPAUTP0.dbd" + ], + "psb": "app/app-authorization-ims-db2-mq/ims/PAUTBUNL.PSB", + "seed": { + "DBPAUTP0": { + "unload": "app/app-authorization-ims-db2-mq/data/EBCDIC/AWS.M2.CARDDEMO.IMSDATA.DBPAUTP0.dat" + } + }, + "segments": { + "PAUTSUM0": { + "copybook": "app/app-authorization-ims-db2-mq/cbl/PAUDBUNL.CBL", + "record": "PENDING-AUTH-SUMMARY" + }, + "PAUTDTL1": { + "copybook": "app/app-authorization-ims-db2-mq/cbl/PAUDBUNL.CBL", + "record": "PENDING-AUTH-DETAILS" + } + }, + "compare": [ + "DBPAUTP0" + ] + }, + "notes": "Job UNLDPADB step STEP01 (DFSRRC00 PARM='DLI,PAUDBUNL,PAUTBUNL'): IMS enters PAUDBUNL at ENTRY 'DLITCBL' with the one DB PCB of PSB PAUTBUNL, and it unloads the pending-authorization database DBPAUTP0 (HIDAM: root PAUTSUM0, child PAUTDTL1) with GN / GNP calls into OUTFIL1 (the roots) and OUTFIL2 (each child behind its root's key). The database is the corpus's own HD unload (data/EBCDIC/AWS.M2.CARDDEMO.IMSDATA.DBPAUTP0.dat: 22 roots, 202 children), each segment laid out by its copybook (CIPAUSMY / CIPAUDTY); its last root's key is EBCDIC spaces, so PA-ACCT-ID IS NUMERIC fails for it and it is skipped. The DL/I model is register family I (tests/equivalence/ims/ggdli.c, cobolrt/dli/DetDli.java), #4893. Derived from CardDemo (Apache-2.0; Copyright Amazon.com, Inc. or its affiliates): LICENSE and NOTICE here are the source's own." +} diff --git a/tests/equivalence/ims/ggdli.c b/tests/equivalence/ims/ggdli.c new file mode 100644 index 0000000000..a82bafdb4d --- /dev/null +++ b/tests/equivalence/ims/ggdli.c @@ -0,0 +1,682 @@ +/* + * ggdli.c -- the IMS DL/I database model of the equivalence harness (#4893): what a batch DL/I program (IMS calls its + * ENTRY 'DLITCBL' with its PCBs; it issues CALL 'CBLTDLI') runs against under GnuCOBOL, which has no IMS. Its Java twin + * is the det runtime's cobolrt/dli/DetDli.java: the same rules, the same refusals. Register family I + * (docs/language_status/register/I*.md) states every rule, every assumption and every refusal; the reference is IBM's + * IMS Application Programming (DL/I calls, SSAs, the DB PCB mask, current position) and IMS Messages and Codes (DL/I + * status codes). + * + * CALL 'GGDLINIT' USING pcb-1 ... pcb-n the harness's driver, before it enters the program: binds each DB PCB of + * the PSB (psb.cfg, in order) to the area passed, and fills its mask + * CALL 'CBLTDLI' USING function pcb io-area [ssa-1 ... ssa-15] + * CALL 'GGDLIEND' the driver, after the program returns: writes each database + * + * Inputs ($GGDLI_DIR, written by tests/tools/equivalence_ims.py from the case's DBD / PSB sources and seed): + * dbd.cfg DBD / SEGM / + * FIELD + * psb.cfg PCB , one line per DB PCB in PSB order + * seed. the database in hierarchic sequence: per segment, its 8-byte name and its BYTES of data + * Output ($GGDLI_OUT/.out): each database at the end, in the seed's format. + * + * Modelled (IMS Messages and Codes, "DL/I status codes"): GU GHU GN GHN GNP GHNP ISRT REPL DLET through a DB PCB, with + * unqualified SSAs and SSAs qualified by one field (EQ GT LT GE LE NE and their symbolic forms) on a C / X field (a + * byte comparison) or a P field whose operands both carry the same positive sign (where IMS's packed and logical + * comparisons agree); status blank, GA, GK, GE, GB, GP, II, DJ, DA, AC, AJ, AK, AD, AM. Anything else -- command codes, + * boolean qualification, another function, a call whose answer depends on what this model leaves open (register I5) + * -- writes "CBLTDLI: ... is not modelled" to stderr and ends the run (exit 98): no proof rests on a guess. + * Each call returns 0 (RETURN-CODE 0, register I1). + */ +extern int cob_get_num_params(void); /* libcob: the argument count of the current CALL */ +#include +#include +#include + +#define MAXSEG 64 +#define MAXFLD 256 +#define MAXPCB 32 +#define MAXDB 16 +#define MAXSSA 15 + +typedef struct { + char name[9]; + int db, parent, bytes, level, key; /* key: the sequence field (index into flds), or -1 */ +} Segm; +typedef struct { + char name[9]; + int seg, start, bytes; + char type; +} Fld; +typedef struct Node { + int seg; + unsigned char *data; + struct Node *parent, *first, *next; +} Node; +enum { POS_START, POS_AT, POS_UNKNOWN }; +enum { PAR_NONE, PAR_AT, PAR_UNKNOWN }; +typedef struct { + int db, keylen, sensegs; + char procopt[5]; + unsigned char *mask; + int pos; /* POS_START: before the first segment; POS_AT: on `at`; POS_UNKNOWN: left open (register I3) */ + Node *at; + int par; /* parentage: PAR_AT on `parent` */ + Node *parentage; + Node *hold; /* the segment a get-hold call returned, until the next call on this PCB */ + int prevknown; /* `at` is the previous segment for GA / GK */ +} Pcb; +typedef struct { + char name[9]; + Node root; /* a virtual node: its children are the root segments */ +} Db; + +static Segm segs[MAXSEG]; +static Fld flds[MAXFLD]; +static Db dbs[MAXDB]; +static Pcb pcbs[MAXPCB]; +static int nseg, nfld, ndb, npcb, loaded; + +static void refuse(const char *what) { + fprintf(stderr, "CBLTDLI: %s is not modelled\n", what); + exit(98); +} + +static void name8(char *out, const unsigned char *in) { + memcpy(out, in, 8); + out[8] = 0; + for (int i = 7; i >= 0 && out[i] == ' '; i--) out[i] = 0; +} + +static int find_seg(int db, const char *name) { + for (int i = 0; i < nseg; i++) + if (segs[i].db == db && !strcmp(segs[i].name, name)) return i; + return -1; +} + +static int find_fld(int seg, const char *name) { + for (int i = 0; i < nfld; i++) + if (flds[i].seg == seg && !strcmp(flds[i].name, name)) return i; + return -1; +} + +static FILE *open_in(const char *file) { + const char *dir = getenv("GGDLI_DIR"); + char path[4096]; + if (!dir) refuse("a run with no database stated (GGDLI_DIR)"); + snprintf(path, sizeof path, "%s/%s", dir, file); + return fopen(path, "rb"); +} + +static int key_cmp(const Node *a, const unsigned char *kb) { + const Fld *k = &flds[segs[a->seg].key]; + return memcmp(a->data + k->start - 1, kb, k->bytes); +} + +/* A child in its place: after the twins of earlier segment types (DBD order), among its own twins in key order. */ +static void link_child(Node *parent, Node *n) { + Node **p = &parent->first; + const Fld *k = &flds[segs[n->seg].key]; + while (*p && ((*p)->seg < n->seg || ((*p)->seg == n->seg && key_cmp(*p, n->data + k->start - 1) < 0))) + p = &(*p)->next; + n->next = *p; + *p = n; + n->parent = parent; +} + +static void load_db(int d) { + char file[64]; + snprintf(file, sizeof file, "seed.%s", dbs[d].name); + FILE *f = open_in(file); + if (!f) return; /* no seed: an empty database */ + Node *last[MAXSEG] = {0}; + unsigned char nm[8]; + while (fread(nm, 1, 8, f) == 8) { + char name[9]; + name8(name, nm); + int s = find_seg(d, name); + if (s < 0) refuse("a seed segment the DBD does not define"); + Node *n = calloc(1, sizeof *n); + n->seg = s; + n->data = malloc(segs[s].bytes); + if (fread(n->data, 1, segs[s].bytes, f) != (size_t)segs[s].bytes) refuse("a truncated seed"); + Node *parent = segs[s].parent < 0 ? &dbs[d].root : last[segs[s].parent]; + if (!parent) refuse("a seed segment before its parent"); + /* the seed must already be in hierarchic sequence: appended, it lands last among its parent's children */ + Node *t = parent->first, *prev = NULL; + while (t) { + prev = t; + t = t->next; + } + if (prev && (prev->seg > s || (prev->seg == s && key_cmp(prev, n->data + flds[segs[s].key].start - 1) >= 0))) + refuse("a seed not in hierarchic sequence (twins in byte order of their keys)"); + n->parent = parent; + if (prev) + prev->next = n; + else + parent->first = n; + last[s] = n; + for (int c = 0; c < nseg; c++) + if (segs[c].db == d && segs[c].level > segs[s].level) last[c] = NULL; + } + fclose(f); +} + +static void load(void) { + if (loaded) return; + loaded = 1; + FILE *f = open_in("dbd.cfg"); + if (!f) refuse("a run with no dbd.cfg"); + char line[512], a[64], b[64], c[64], e[64], g[8], h[8]; + int x, y; + while (fgets(line, sizeof line, f)) { + if (sscanf(line, "DBD %63s", a) == 1) { + snprintf(dbs[ndb].name, 9, "%.8s", a); + dbs[ndb].root.seg = -1; + ndb++; + } else if (sscanf(line, "SEGM %63s %63s %63s %d", a, b, c, &x) == 4) { + Segm *s = &segs[nseg]; + s->db = ndb - 1; + snprintf(s->name, 9, "%.8s", b); + s->bytes = x; + s->key = -1; + s->parent = strcmp(c, "0") ? find_seg(ndb - 1, c) : -1; + s->level = s->parent < 0 ? 1 : segs[s->parent].level + 1; + nseg++; + } else if (sscanf(line, "FIELD %63s %63s %63s %d %d %7s %7s", a, b, e, &x, &y, g, h) == 7) { + Fld *fl = &flds[nfld]; + fl->seg = find_seg(ndb - 1, b); + snprintf(fl->name, 9, "%.8s", e); + fl->start = x; + fl->bytes = y; + fl->type = g[0]; + if (h[0] == 'S') segs[fl->seg].key = nfld; + nfld++; + } + } + fclose(f); + for (int s = 0; s < nseg; s++) + if (segs[s].key < 0) refuse("a segment with no sequence field"); + for (int d = 0; d < ndb; d++) load_db(d); +} + +static void put_fullword(unsigned char *p, int v) { + p[0] = (unsigned char)(v >> 24); + p[1] = (unsigned char)(v >> 16); + p[2] = (unsigned char)(v >> 8); + p[3] = (unsigned char)v; +} + +typedef unsigned char *P; + +int GGDLINIT(P a0, P a1, P a2, P a3, P a4, P a5, P a6, P a7, P a8, P a9, P a10, P a11, P a12, P a13, P a14, P a15) { + P areas[16] = {a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15}; + load(); + FILE *f = open_in("psb.cfg"); + if (!f) refuse("a run with no psb.cfg"); + char line[256], a[64], b[64]; + int k; + while (fgets(line, sizeof line, f)) { + if (sscanf(line, "PCB %63s %63s %d", a, b, &k) != 3) continue; + if (npcb == 16) refuse("a PSB of more than 16 DB PCBs"); + Pcb *p = &pcbs[npcb]; + p->db = -1; + for (int d = 0; d < ndb; d++) + if (!strcmp(dbs[d].name, a)) p->db = d; + snprintf(p->procopt, 5, "%.4s", b); + p->keylen = k; + p->sensegs = 0; + for (int s = 0; s < nseg; s++) + if (segs[s].db == p->db) p->sensegs++; + npcb++; + } + fclose(f); + if (cob_get_num_params() != npcb) refuse("an entry whose USING does not list one area per PCB of the PSB"); + for (int i = 0; i < npcb; i++) { + Pcb *p = &pcbs[i]; + p->mask = areas[i]; + memset(p->mask, ' ', 36); + memcpy(p->mask, dbs[p->db].name, strlen(dbs[p->db].name)); + memcpy(p->mask + 8, "00", 2); + memcpy(p->mask + 12, p->procopt, strlen(p->procopt)); + put_fullword(p->mask + 16, 0); + put_fullword(p->mask + 28, 0); + put_fullword(p->mask + 32, p->sensegs); + memset(p->mask + 36, 0, p->keylen); + p->pos = POS_START; + p->par = PAR_NONE; + } + return 0; +} + +static void dump_node(FILE *f, const Node *n) { + for (const Node *c = n->first; c; c = c->next) { + char nm[8]; + memset(nm, ' ', 8); + memcpy(nm, segs[c->seg].name, strlen(segs[c->seg].name)); + fwrite(nm, 1, 8, f); + fwrite(c->data, 1, segs[c->seg].bytes, f); + dump_node(f, c); + } +} + +int GGDLIEND(void) { + const char *out = getenv("GGDLI_OUT"); + if (!out) return 0; + load(); + for (int d = 0; d < ndb; d++) { + char path[4096]; + snprintf(path, sizeof path, "%s/%s.out", out, dbs[d].name); + FILE *f = fopen(path, "wb"); + if (!f) refuse("an unwritable GGDLI_OUT"); + dump_node(f, &dbs[d].root); + fclose(f); + } + return 0; +} + +/* ---- the database's hierarchic sequence ---------------------------------------------------------------------- */ +static Node *next_in_seq(Node *n) { + if (n->first) return n->first; + while (n) { + if (n->next) return n->next; + n = n->parent; + } + return NULL; +} + +static Node *db_first(int d) { return dbs[d].root.first; } + +static int descends(const Node *n, const Node *anc) { + for (const Node *p = n->parent; p; p = p->parent) + if (p == anc) return 1; + return 0; +} + +static Node *last_in_subtree(Node *n) { + while (n->first) { + Node *c = n->first; + while (c->next) c = c->next; + n = c; + } + return n; +} + +/* segment type t is `anc` or below it */ +static int descends_type(int t, int anc) { + for (; t >= 0; t = segs[t].parent) + if (t == anc) return 1; + return 0; +} + +static Node *ancestor_of_type(Node *n, int seg) { + for (; n && n->parent; n = n->parent) + if (n->seg == seg) return n; + return NULL; +} + +/* ---- SSAs ------------------------------------------------------------------------------------------------------ */ +typedef struct { + int seg, fld, op; /* fld -1: unqualified; op 0 EQ 1 GT 2 LT 3 GE 4 LE 5 NE */ + const unsigned char *value; +} Ssa; + +static const char *OPS[][3] = {{"EQ", " =", "= "}, {"GT", " >", "> "}, {"LT", " <", "< "}, + {"GE", ">=", "=>"}, {"LE", "<=", "=<"}, {"NE", "\xac=", "=\xac"}}; + +/* The SSAs of a call: 0, or the status code that rejects them. */ +static const char *parse_ssas(int db, unsigned char **raw, int n, Ssa *out) { + for (int i = 0; i < n; i++) { + char nm[9]; + name8(nm, raw[i]); + out[i].seg = find_seg(db, nm); + out[i].fld = -1; + if (out[i].seg < 0) return "AC"; + unsigned char q = raw[i][8]; + if (q == ' ') continue; + if (q == '*') refuse("an SSA with command codes"); + if (q != '(') return "AJ"; + name8(nm, raw[i] + 9); + out[i].fld = find_fld(out[i].seg, nm); + if (out[i].fld < 0) return "AK"; + out[i].op = -1; + for (int o = 0; o < 6; o++) + for (int v = 0; v < 3; v++) + if (!memcmp(raw[i] + 17, OPS[o][v], 2)) out[i].op = o; + if (out[i].op < 0) return "AJ"; + out[i].value = raw[i] + 19; + unsigned char end = raw[i][19 + flds[out[i].fld].bytes]; + if (end == '&' || end == '*' || end == '+' || end == '|' || end == '#') refuse("a boolean SSA qualification"); + if (end != ')') return "AJ"; + char t = flds[out[i].fld].type; + if (t != 'C' && t != 'X' && t != 'P') refuse("a qualification on a field of a type other than C, X or P"); + } + return 0; +} + +static int packed_sign(const unsigned char *p, int n) { + for (int i = 0; i < n; i++) { + if ((p[i] >> 4) > 9) return -1; + if (i < n - 1 && (p[i] & 15) > 9) return -1; + } + return p[n - 1] & 15; +} + +static int qualifies(const Node *n, const Ssa *s) { + if (s->fld < 0) return 1; + const Fld *f = &flds[s->fld]; + const unsigned char *a = n->data + f->start - 1; + if (f->type == 'P') { + int sa = packed_sign(a, f->bytes), sb = packed_sign(s->value, f->bytes); + if (sa < 0 || sb < 0 || sa != sb || (sa != 0xC && sa != 0xF)) + refuse("a P-field qualification on operands that are not both valid with one positive sign"); + } + int c = memcmp(a, s->value, f->bytes); + switch (s->op) { + case 0: return c == 0; + case 1: return c > 0; + case 2: return c < 0; + case 3: return c >= 0; + case 4: return c <= 0; + default: return c != 0; + } +} + +/* n (of the last SSA's type) satisfies every SSA: each one's segment type is n or an ancestor of n */ +static int satisfies(Node *n, const Ssa *s, int k) { + if (k == 0) return 1; + if (n->seg != s[k - 1].seg) return 0; + for (int i = 0; i < k; i++) { + Node *a = ancestor_of_type(n, s[i].seg); + if (!a || !qualifies(a, &s[i])) return 0; + } + return 1; +} + +/* SSAs in hierarchic order, each the child of the one before: 0, "AC", or a refusal */ +static const char *chain(const Ssa *s, int k) { + for (int i = 1; i < k; i++) { + int p = segs[s[i].seg].parent; + if (p == s[i - 1].seg) continue; + while (p >= 0 && p != s[i - 1].seg) p = segs[p].parent; + if (p < 0) return "AC"; + refuse("SSAs that leave out an intermediate level"); + } + return 0; +} + +/* ---- the PCB mask ---------------------------------------------------------------------------------------------- */ +static void status(Pcb *p, const char *st) { memcpy(p->mask + 10, st, 2); } + +static void feedback(Pcb *p, Node *n) { + char lv[3]; + Node *path[MAXSEG]; + int depth = 0, len = 0; + if (!n || !n->parent) { + memcpy(p->mask + 8, "00", 2); + memset(p->mask + 20, ' ', 8); + put_fullword(p->mask + 28, 0); + return; + } + snprintf(lv, sizeof lv, "%02d", segs[n->seg].level); + memcpy(p->mask + 8, lv, 2); + memset(p->mask + 20, ' ', 8); + memcpy(p->mask + 20, segs[n->seg].name, strlen(segs[n->seg].name)); + for (Node *a = n; a && a->parent; a = a->parent) path[depth++] = a; + for (int i = depth - 1; i >= 0; i--) { + const Fld *k = &flds[segs[path[i]->seg].key]; + if (len + k->bytes > p->keylen) refuse("a concatenated key longer than the PCB's KEYLEN"); + memcpy(p->mask + 36 + len, path[i]->data + k->start - 1, k->bytes); + len += k->bytes; + } + put_fullword(p->mask + 28, len); +} + +static int allows(const Pcb *p, char what) { + return strchr(p->procopt, 'A') != NULL || strchr(p->procopt, what) != NULL; +} + +static Pcb *find_pcb(unsigned char *mask) { + for (int i = 0; i < npcb; i++) + if (pcbs[i].mask == mask) return &pcbs[i]; + refuse("a PCB the program was not passed"); + return NULL; +} + +/* GU / GN / GNP and their holds */ +static void get(Pcb *p, const char *fn, unsigned char *io, Ssa *s, int k, int hold) { + if (!allows(p, 'G')) { + status(p, "AM"); + return; + } + if (hold && strchr(p->procopt, 'O')) refuse("a get-hold call under PROCOPT O"); + const char *bad = chain(s, k); + if (bad) { + status(p, bad); + return; + } + Node *n = NULL, *from = NULL, *bound = NULL; + int gu = fn[1] == 'U' || fn[2] == 'U', gnp = !gu && strstr(fn, "NP") != NULL; + if (gu) { + if (k && segs[s[0].seg].parent >= 0) refuse("a GU whose SSAs leave out the root level"); + from = db_first(p->db); + } else { + if (gnp) { + if (p->par == PAR_NONE) { + status(p, "GP"); + return; + } + if (p->par == PAR_UNKNOWN) refuse("a GNP after a call that leaves parentage open"); + bound = p->parentage; + if (k) { + int q = segs[s[0].seg].parent; + if (!descends_type(q, bound->seg)) refuse("a GNP whose SSAs name a segment outside its parent"); + } + } + if (p->pos == POS_UNKNOWN) refuse("a GN / GNP after a call that leaves position open"); + if (bound && (p->pos != POS_AT || (p->at != bound && !descends(p->at, bound)))) + refuse("a GNP whose position is outside its parent"); + from = p->pos == POS_START ? db_first(p->db) : next_in_seq(p->at); + } + for (Node *c = from; c; c = next_in_seq(c)) { + if (bound && !descends(c, bound)) break; + if (k ? satisfies(c, s, k) : 1) { + n = c; + break; + } + } + if (!n) { + int qualified = 0; + for (int i = 0; i < k; i++) qualified |= s[i].fld >= 0; + if (gu) { + Node *best = NULL; + for (int j = k - 1; j >= 1 && !best; j--) + for (Node *c = from; c; c = next_in_seq(c)) + if (satisfies(c, s, j)) { + best = c; + break; + } + status(p, "GE"); + feedback(p, best); + p->pos = POS_UNKNOWN; + p->par = PAR_UNKNOWN; + } else if (gnp) { + if (qualified) refuse("a qualified GNP that finds nothing (where IMS leaves position)"); + status(p, "GE"); + feedback(p, bound); + p->pos = POS_AT; + p->at = last_in_subtree(bound); + p->prevknown = 0; + } else { + if (qualified) refuse("a qualified GN that finds nothing (GE or GB: IMS's sequence-field search)"); + status(p, "GB"); + p->pos = POS_START; + p->prevknown = 0; + } + return; + } + const char *st = " "; + if (!gu && k == 0 && p->prevknown && p->pos == POS_AT) { + if (segs[n->seg].level < segs[p->at->seg].level) + st = "GA"; + else if (segs[n->seg].level == segs[p->at->seg].level && n->seg != p->at->seg) + st = "GK"; + } + memcpy(io, n->data, segs[n->seg].bytes); + status(p, st); + feedback(p, n); + p->pos = POS_AT; + p->at = n; + p->prevknown = 1; + if (!gnp) { + p->par = PAR_AT; + p->parentage = n; + } + if (hold) p->hold = n; +} + +/* ISRT: the last SSA names the type inserted (unqualified); the SSAs before it locate the parent, from the root, or + * there are none and current position does */ +static void isrt(Pcb *p, unsigned char *io, Ssa *s, int k) { + if (!allows(p, 'I')) { + status(p, "AM"); + return; + } + if (k == 0) refuse("an ISRT with no SSA"); + if (s[k - 1].fld >= 0) refuse("an ISRT whose last SSA is qualified"); + const char *bad = chain(s, k); + if (bad) { + status(p, bad); + return; + } + int t = s[k - 1].seg; + Node *parent; + if (segs[t].parent < 0) { + if (k > 1) refuse("an ISRT of a root with SSAs before it"); + parent = &dbs[p->db].root; + } else if (k == 1) { + if (p->pos != POS_AT) refuse("an ISRT that relies on a position left open"); + parent = ancestor_of_type(p->at, segs[t].parent); + if (!parent) refuse("an ISRT whose parent is not on the current position's path"); + } else { + if (segs[s[0].seg].parent >= 0) refuse("an ISRT whose SSAs leave out the root level"); + parent = NULL; + for (Node *c = db_first(p->db); c; c = next_in_seq(c)) + if (satisfies(c, s, k - 1)) { + parent = c; + break; + } + if (!parent) { + Node *best = NULL; + for (int j = k - 2; j >= 1 && !best; j--) + for (Node *c = db_first(p->db); c; c = next_in_seq(c)) + if (satisfies(c, s, j)) { + best = c; + break; + } + status(p, "GE"); + feedback(p, best); + p->pos = POS_UNKNOWN; + p->par = PAR_UNKNOWN; + return; + } + } + const Fld *key = &flds[segs[t].key]; + for (Node *c = parent->first; c; c = c->next) + if (c->seg == t && key_cmp(c, io + key->start - 1) == 0) { + status(p, "II"); + feedback(p, parent->parent ? parent : NULL); + p->pos = POS_UNKNOWN; + p->par = PAR_UNKNOWN; + return; + } + Node *n = calloc(1, sizeof *n); + n->seg = t; + n->data = malloc(segs[t].bytes); + memcpy(n->data, io, segs[t].bytes); + link_child(parent, n); + status(p, " "); + feedback(p, n); + p->pos = POS_AT; + p->at = n; + p->prevknown = 0; + p->par = PAR_UNKNOWN; +} + +/* REPL / DLET: on the segment the previous call on this PCB held */ +static void change(Pcb *p, int dlet, unsigned char *io, Node *held, int k) { + if (!allows(p, dlet ? 'D' : 'R')) { + status(p, "AM"); + return; + } + if (k) refuse(dlet ? "a DLET with SSAs" : "a REPL with SSAs"); + if (!held) { + status(p, "DJ"); + return; + } + const Fld *key = &flds[segs[held->seg].key]; + if (key_cmp(held, io + key->start - 1) != 0) { + status(p, "DA"); + return; + } + status(p, " "); + if (!dlet) { + memcpy(held->data, io, segs[held->seg].bytes); + return; + } + /* position: on the segment before the deleted one in hierarchic sequence (the next call goes on after it) */ + Node *prev = NULL; + for (Node *c = db_first(p->db); c && c != held; c = next_in_seq(c)) prev = c; + Node **link = &held->parent->first; + while (*link != held) link = &(*link)->next; + *link = held->next; + for (int i = 0; i < npcb; i++) { /* another PCB on the deleted segments has its position left open */ + Pcb *o = &pcbs[i]; + if (o != p && o->db == p->db && o->pos == POS_AT && (o->at == held || descends(o->at, held))) + o->pos = POS_UNKNOWN; + if (o->par == PAR_AT && (o->parentage == held || descends(o->parentage, held))) o->par = PAR_UNKNOWN; + } + p->pos = prev ? POS_AT : POS_START; + p->at = prev; + p->prevknown = 0; +} + +int CBLTDLI(P a0, P a1, P a2, P a3, P a4, P a5, P a6, P a7, P a8, P a9, P a10, P a11, P a12, P a13, P a14, P a15, + P a16, P a17) { + P args[18] = {a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17}; + int n = cob_get_num_params(); + load(); + if (n < 2) refuse("a call with fewer than a function and a PCB"); + Pcb *p = find_pcb(args[1]); + char fn[5]; + memcpy(fn, args[0], 4); + fn[4] = 0; + Node *held = p->hold; + p->hold = NULL; + static const char *KNOWN[] = {"GU ", "GHU ", "GN ", "GHN ", "GNP ", "GHNP", "ISRT", "REPL", "DLET", NULL}; + static const char *OTHER[] = {"CHKP", "XRST", "ROLB", "ROLL", "ROLS", "SETS", "SETU", "SYNC", "LOG ", "STAT", "GSCD", + "FLD ", "POS ", "INIT", "INQY", "SNAP", "PCB ", "TERM", "GMSG", "ICMD", "RCMD", "CMD ", + "GCMD", "AUTH", "CHNG", "PURG", "DEQ ", "SETO", "APSB", "DPSB", "GSTA", NULL}; + int known = 0; + for (int i = 0; KNOWN[i]; i++) known |= !strcmp(fn, KNOWN[i]); + if (!known) { + for (int i = 0; OTHER[i]; i++) + if (!strcmp(fn, OTHER[i])) refuse("a DL/I call other than GU GHU GN GHN GNP GHNP ISRT REPL DLET"); + status(p, "AD"); + return 0; + } + if (n < 3) refuse("a database call with no I/O area"); + int k = n - 3; + if (k > MAXSSA) refuse("more than 15 SSAs"); + Ssa s[MAXSSA]; + const char *bad = parse_ssas(p->db, args + 3, k, s); + if (bad) { + status(p, bad); + return 0; + } + if (fn[0] == 'G') + get(p, fn, args[2], s, k, fn[1] == 'H'); + else if (!strcmp(fn, "ISRT")) + isrt(p, args[2], s, k); + else + change(p, fn[0] == 'D', args[2], held, k); + return 0; +} diff --git a/tests/tools/equivalence.py b/tests/tools/equivalence.py index 581556bba0..be8e8f32d4 100644 --- a/tests/tools/equivalence.py +++ b/tests/tools/equivalence.py @@ -99,6 +99,7 @@ # The primitives every harness module shares live in a leaf module (no cycle); re-exported here. import equivalence_db2 +import equivalence_ims import equivalence_oracle import equivalence_sql from equivalence_common import ( @@ -265,7 +266,18 @@ def run_cobol(case: dict[str, Any], corpus: Path, work: Path, fault: dict[str, A script.append(f"INFILE=/work/{dd}.in {dd}=/work/{dd}.idx ./ld{dd}") elif "input" in spec: script.append(f"cp /work/{dd}.in /work/{dd}.idx") - (src / "EQDRIVER.cbl").write_text(cobol_driver(case["program"], case.get("parm")), encoding="ascii") + ims = case.get("ims") + if ims: # #4893: a DL/I program -- IMS enters it at DLITCBL with its PCBs -- on the stated databases (ggdli.c) + try: + pcbs = equivalence_ims.stage(case, corpus, source, work / "dli") + except equivalence_ims.Unsupported as e: + raise RuntimeError(f"not runnable faithfully: {e}") from e + (src / "EQDRIVER.cbl").write_text(_cbl(equivalence_ims.cobol_driver("DLITCBL", pcbs)), encoding="ascii") + shutil.copy(equivalence_ims.STUB, src / "ggdli.c") + shutil.rmtree(work / "dliout", ignore_errors=True) + (work / "dliout").mkdir() + else: + (src / "EQDRIVER.cbl").write_text(cobol_driver(case["program"], case.get("parm")), encoding="ascii") for stub in ("ggabend.c", "ggfault.c", "ggdisplay.c"): shutil.copy(FAULTS_DIR / stub, src / stub) models = sorted(LE_MODELS.glob("*.c")) @@ -273,6 +285,7 @@ def run_cobol(case: dict[str, Any], corpus: Path, work: Path, fault: dict[str, A shutil.copy(m, src / m.name) # #4023: traced; CEE3ABD is the abend stub, which records the abend instead of failing the CALL sql = f" src/ggsql.c {equivalence_db2.COBOL_LINK}" if db2 else "" + sql += " src/ggdli.c" if ims else "" le = "".join(f" src/{m.name}" for m in models) script.append( f"cobc -x {flags} {cov.TRACE_FLAG} -o program src/EQDRIVER.cbl src/PROGRAM.cbl src/ggabend.c{le}{sql}" @@ -291,6 +304,7 @@ def run_cobol(case: dict[str, Any], corpus: Path, work: Path, fault: dict[str, A tz = f"TZ='{case['zone']}' " if case.get("zone") else "" # the step's RETURN-CODE is an output like any other (CBTRN02C sets 4 when it rejects): recorded, not fatal sqlenv = equivalence_db2.cobol_env("/work/stmts.txt") if db2 else "" + sqlenv += "GGDLI_DIR=/work/dli GGDLI_OUT=/work/dliout " if ims else "" if db2: # #4173: each statement the step runs traced; a fault run's SQL faults, those that fire logged # #4507: and what Db2 answered each one (equivalence_db2.cobol_outcomes) sqlenv += "GGSQL_TRACE=/work/sqltrace.txt GGSQL_OUTCOMES=/work/sqlout.txt GGSQL_FAULTS_LOG=/work/FAULTS " @@ -326,6 +340,9 @@ def run_cobol(case: dict[str, Any], corpus: Path, work: Path, fault: dict[str, A for t in db2.get("compare", []): f = saved / f"DB2_{t}" outs[f"DB2 {t}"] = f.read_bytes() if f.is_file() else b"" + for name in (ims or {}).get("compare", []): # #4893: each database as the step left it (ggdli.c GGDLIEND) + f = work / "dliout" / f"{name}.out" + outs[f"IMS {name}"] = f.read_bytes() if f.is_file() else b"" outs["SYSOUT"] = (work / "stdout.txt").read_bytes() if (work / "stdout.txt").is_file() else b"" # #4056 if db2 and db2.get("compare_sql"): # #4507: what Db2 answered the step's statements outs["SQL"] = (work / "sqlout.txt").read_bytes() if (work / "sqlout.txt").is_file() else b"" @@ -614,6 +631,11 @@ def compare_run(case: dict[str, Any], corpus: Path, cobol: dict[str, bytes], jav if d["equal"] != d["records"] or d["diffs"]: why.append(f"{dd}: {d['equal']}/{d['records']} records equal") _compare_tables(case, cobol, java, run, why) + for name in (case.get("ims") or {}).get("compare", []): # #4893: each database, segment by segment + d = equivalence_ims.diff_db(case, corpus, name, cobol.get(f"IMS {name}", b""), java.get(f"IMS {name}", b"")) + run["outputs"][f"IMS {name}"] = d + if d["diffs"]: + why.append(f"IMS {name}: {d['records'] - len(d['diffs'])}/{d['records']} segments equal") # #4507: what Db2 answered each side's statements (not a run with planned SQL faults: those are compared as # fired faults) if (case.get("db2") or {}).get("compare_sql") and not (fault or {}).get("sql_plan"): diff --git a/tests/tools/equivalence_ims.py b/tests/tools/equivalence_ims.py new file mode 100644 index 0000000000..692feb03cc --- /dev/null +++ b/tests/tools/equivalence_ims.py @@ -0,0 +1,318 @@ +""" +IMS DL/I databases in the equivalence harness (#4893; see equivalence.py). + +A batch case's `"ims"` section states the databases a DL/I program (IMS enters its ENTRY 'DLITCBL' with its PCBs; it +issues CALL 'CBLTDLI') runs against, and both sides run on the same stated content: + + "ims": {"dbd": ["", ...], "psb": "", + "seed": {"": {"unload": ""} | {"segments": [{"segment": S, "text" | "hex": ...}]}}, + "segments": {"": {"copybook": "", "record": "<01 name>"}}, + "compare": ["", ...]} + +The DBD and PSB sources are read by the engine's own macro reader (gitgalaxy/core/ims_gen.py); what this model does +not model is refused here by name (Unsupported): HDAM / PHDAM (the randomizer's root order), logical relationships, +variable-length segments, a non-unique or missing sequence field, an I/O PCB (CMPAT=YES, TYPE=TP: IMS TM), a GSAM PCB, +PROCSEQ (a secondary index), load mode (PROCOPT L / LS), segment-level PROCOPT and partial sensitivity. +`{"unload": ...}` reads an HD reorganization unload (DFSURGU0) of the corpus: its segments, EBCDIC, each laid out by +its copybook (`segments`) into the case's data page (text through CCSID 037, COMP / COMP-3 bytes as they are), its +trailer's segment counts checked. + +Written for both sides into one directory (`stage`): dbd.cfg, psb.cfg and seed. (tests/equivalence/ims/ggdli.c +documents the format); each side writes .out, the database as the step left it, compared segment by segment +(`diff_db`) with every field of its segment's layout. +""" + +from __future__ import annotations + +import re +import sys +from pathlib import Path +from typing import Any + +REPO = Path(__file__).resolve().parents[2] +if str(REPO) not in sys.path: + sys.path.insert(0, str(REPO)) + +from gitgalaxy.core.ims_gen import ims_gen_macros # noqa: E402 + +import equivalence_common as common # noqa: E402 + +STUB = Path(__file__).resolve().parents[1] / "equivalence" / "ims" / "ggdli.c" +MASK = 36 # the DB PCB mask before its key feedback area (IMS Application Programming, "DB PCB mask") +AREA = 4096 # the area the COBOL driver passes per PCB: at least the PCB, and every byte a LINKAGE mask may name +ACCESS = ("HIDAM", "PHIDAM", "HISAM", "SHISAM") + + +class Unsupported(ValueError): + """What the DL/I model does not model: the case is not runnable faithfully.""" + + +def _keyed(attributes: str, key: str) -> str | None: + m = re.search(rf"(?:^|,)\s*{key}\s*=\s*(\([^)]*\)+|[^,\s]+)", attributes or "", re.I) + return m.group(1).upper() if m else None + + +def dbd(text: str, where: str) -> dict[str, Any]: + """One DBD source: {name, segments: [{name, parent, bytes, fields: [{name, start, bytes, type, seq}]}]}.""" + rows = ims_gen_macros(text) + db = next((r for r in rows if r["kind"] == "DBD"), None) + if db is None: + raise Unsupported(f"{where}: no DBD statement") + access = (db["access"] or "").upper() + if access not in ACCESS: + raise Unsupported(f"{where}: ACCESS={access or '?'} (only {', '.join(ACCESS)}: the root sequence of an HDAM " + "database is its randomizer's, a GSAM / INDEX / LOGICAL database is no hierarchy here)") # fmt: skip + segs: list[dict[str, Any]] = [] + for r in rows: + attrs = r["attributes"] or "" + if r["kind"] == "SEGM": + parent = (r["parent"] or "0").strip("()").split(",")[0].strip().upper() or "0" + if _keyed(attrs, "SOURCE") or re.search(r"PARENT\s*=\s*\(\([^)]*\)\s*,\s*\(", attrs, re.I): + raise Unsupported(f"{where}: SEGM {r['name']} has a logical relationship (not modelled)") + if r["bytes"] is None or re.search(r"BYTES\s*=\s*\(\s*\d+\s*,", attrs, re.I): + raise Unsupported(f"{where}: SEGM {r['name']}: a variable-length segment (not modelled)") + segs.append({"name": r["name"].upper(), "parent": parent, "bytes": r["bytes"], "fields": []}) + elif r["kind"] == "FIELD" and segs: + names = (_keyed(attrs, "NAME") or "").strip("()").split(",") + seq = len(names) > 1 and names[1].strip() == "SEQ" + if seq and (len(names) < 3 or names[2].strip() != "U"): + raise Unsupported(f"{where}: FIELD {r['name']}: a non-unique sequence field (not modelled)") + if r["start"] is None or r["bytes"] is None: + raise Unsupported(f"{where}: FIELD {r['name']}: START / BYTES not literal") + segs[-1]["fields"].append({"name": r["name"].upper(), "start": r["start"], "bytes": r["bytes"], + "type": (_keyed(attrs, "TYPE") or "C")[0], "seq": seq}) # fmt: skip + for s in segs: + if not any(f["seq"] for f in s["fields"]): + raise Unsupported(f"{where}: SEGM {s['name']} has no sequence field (twin order FIRST / LAST / HERE: " + "not modelled)") # fmt: skip + return {"name": db["name"].upper(), "segments": segs} + + +def psb(text: str, where: str, dbds: dict[str, dict[str, Any]]) -> list[dict[str, Any]]: + """The PSB's DB PCBs, in order: [{dbd, procopt, keylen}]; an I/O or GSAM PCB, or what else is not modelled, + refused.""" + rows = ims_gen_macros(text) + gen = next((r for r in rows if r["kind"] == "PSBGEN"), None) + if gen is None: + raise Unsupported(f"{where}: no PSBGEN statement") + if (_keyed(gen["attributes"], "CMPAT") or "NO") == "YES": + raise Unsupported(f"{where}: CMPAT=YES (IMS passes an I/O PCB first: IMS TM, not modelled)") + pcbs: list[dict[str, Any]] = [] + for r in rows: + attrs = r["attributes"] or "" + if r["kind"] == "PCB": + if (r["pcb_type"] or "").upper() != "DB": + raise Unsupported(f"{where}: a TYPE={r['pcb_type']} PCB (an I/O, alternate or GSAM PCB: not modelled)") + if _keyed(attrs, "PROCSEQ"): + raise Unsupported(f"{where}: PCB {r['name']}: PROCSEQ (a secondary index) is not modelled") + procopt = (r["procopt"] or "A").upper() + if "L" in procopt: + raise Unsupported(f"{where}: PCB {r['name']}: PROCOPT={procopt} (load mode) is not modelled") + name = (r["dbd_name"] or "").upper() + if name not in dbds: + raise Unsupported(f"{where}: PCB {r['name']}: DBD {name} is not one of the case's DBDs") + keylen = _keyed(attrs, "KEYLEN") + if not (keylen or "").isdigit(): + raise Unsupported(f"{where}: PCB {r['name']}: KEYLEN not literal") + pcbs.append({"dbd": name, "procopt": procopt[:4], "keylen": int(keylen or 0), "sensegs": []}) + elif r["kind"] == "SENSEG" and pcbs: + if r["procopt"]: + raise Unsupported(f"{where}: SENSEG {r['name']}: a segment-level PROCOPT is not modelled") + pcbs[-1]["sensegs"].append((r["name"] or "").upper()) + for p in pcbs: + every = [s["name"] for s in dbds[p["dbd"]]["segments"]] + if sorted(p["sensegs"]) != sorted(every): + raise Unsupported(f"{where}: a PCB on {p['dbd']} sensitive to {p['sensegs']}, not to every segment " + "(partial sensitivity is not modelled)") # fmt: skip + return pcbs + + +def definitions(case: dict[str, Any], corpus: Path) -> tuple[dict[str, dict[str, Any]], list[dict[str, Any]]]: + ims = case["ims"] + dbds: dict[str, dict[str, Any]] = {} + for rel in ims["dbd"]: + d = dbd((corpus / rel).read_text(encoding="latin-1"), rel) + dbds[d["name"]] = d + return dbds, psb((corpus / ims["psb"]).read_text(encoding="latin-1"), ims["psb"], dbds) + + +def _layout(case: dict[str, Any], corpus: Path, seg: str) -> list[dict[str, Any]] | None: + spec = case["ims"].get("segments", {}).get(seg) + if not spec: + return None + dirs = [corpus / d for d in case.get("copy_dirs", [])] + return common.layout_fields(corpus, spec["copybook"], spec.get("record"), copy_dirs=[*dirs, corpus], + occurrences=True) # fmt: skip + + +def _binary(f: dict[str, Any]) -> bool: + return (f.get("usage") or "DISPLAY").upper() not in ("DISPLAY", "") + + +def from_ebcdic(data: bytes, layout: list[dict[str, Any]], enc: str) -> bytes: + """A segment's EBCDIC bytes in the case's data page: text through CCSID 037, COMP / COMP-3 / POINTER bytes kept.""" + out = bytearray(data.decode("cp037").encode(enc)) + if len(out) != len(data): + raise Unsupported(f"data page {enc} is not single-byte: a segment cannot be laid out") + for f in layout: + if _binary(f): + out[f["offset"] : f["offset"] + f["bytes"]] = data[f["offset"] : f["offset"] + f["bytes"]] + return bytes(out) + + +def unload(path: Path) -> list[tuple[str, bytes]]: + """An HD reorganization unload (DFSURGU0, the corpus's own): [(segment, its EBCDIC data)] in hierarchic sequence. + Each record: a halfword length, a halfword of zeros, the segment level and flag bytes, a halfword, the segment's + length (halfword) and name (8 bytes, EBCDIC) at offset 8 / 10, its data the `length` bytes before the record's + last byte. The first record (level 0) is the header, the last (level 0) the trailer: per segment type its name and, + 32 bytes on, a fullword count of its segments -- checked against what was read, so a misread layout is never + seeded.""" + raw = path.read_bytes() + recs, i = [], 0 + while i + 2 <= len(raw): + n = int.from_bytes(raw[i : i + 2], "big") + if n < 18 or i + n > len(raw): + raise Unsupported(f"{path.name}: record at {i} has length {n}: not an HD unload") + recs.append(raw[i : i + n]) + i += n + if len(recs) < 2 or recs[0][4] != 0 or recs[-1][4] != 0: + raise Unsupported(f"{path.name}: no header / trailer record: not an HD unload") + segs = [] + for r in recs[1:-1]: + length = int.from_bytes(r[8:10], "big") + if length + 19 > len(r): + raise Unsupported(f"{path.name}: a segment longer than its record") + segs.append((r[10:18].decode("cp037").rstrip(), r[len(r) - length - 1 : len(r) - 1])) + seen: dict[str, int] = {} + for name, _ in segs: + seen[name] = seen.get(name, 0) + 1 + trailer = recs[-1] + for name, n in seen.items(): + at = trailer.find(name.ljust(8).encode("cp037")) + count = int.from_bytes(trailer[at + 32 : at + 36], "big") if at >= 0 else None + if count != n: + raise Unsupported(f"{path.name}: {n} {name} segments read, the trailer counts {count}") + return segs + + +def seed(case: dict[str, Any], corpus: Path, name: str, db: dict[str, Any]) -> bytes: + """One database's seed, in the format both sides read (8-byte segment name, then its data).""" + spec = case["ims"].get("seed", {}).get(name) + if not spec: + return b"" + enc = common.data_encoding(case) + sizes = {s["name"]: s["bytes"] for s in db["segments"]} + out = bytearray() + if "unload" in spec: + layouts: dict[str, list[dict[str, Any]]] = {} + for seg, data in unload(corpus / spec["unload"]): + if seg not in sizes: + raise Unsupported(f"{spec['unload']}: segment {seg} is not in DBD {name}") + if seg not in layouts: + lay = _layout(case, corpus, seg) + if lay is None: + raise Unsupported(f"segment {seg}: no copybook to lay its EBCDIC bytes out by (ims.segments)") + layouts[seg] = lay + out += seg.ljust(8).encode("ascii") + from_ebcdic(data[: sizes[seg]].ljust(sizes[seg], b"\x40"), + layouts[seg], enc) # fmt: skip + return bytes(out) + for s in spec["segments"]: + size = sizes[s["segment"]] + data = bytes.fromhex(s["hex"]) if "hex" in s else common.text_bytes(s["text"], size, enc) + if len(data) != size: + raise Unsupported(f"seed segment {s['segment']}: {len(data)} bytes, BYTES={size}") + out += s["segment"].ljust(8).encode("ascii") + data + return bytes(out) + + +def config(dbds: dict[str, dict[str, Any]], pcbs: list[dict[str, Any]]) -> tuple[str, str]: + """dbd.cfg and psb.cfg (tests/equivalence/ims/ggdli.c, DetDli.load).""" + lines = [] + for name, db in dbds.items(): + lines.append(f"DBD {name}") + for s in db["segments"]: + lines.append(f"SEGM {name} {s['name']} {s['parent']} {s['bytes']}") + for s in db["segments"]: + for f in s["fields"]: + lines.append(f"FIELD {name} {s['name']} {f['name']} {f['start']} {f['bytes']} {f['type']} " + f"{'S' if f['seq'] else '-'}") # fmt: skip + return "\n".join(lines) + "\n", "".join(f"PCB {p['dbd']} {p['procopt']} {p['keylen']}\n" for p in pcbs) + + +def entry_using(source: str) -> list[str] | None: + """The PCBs the program names at ENTRY 'DLITCBL' (IMS enters a COBOL DL/I program there), else None.""" + code = "\n".join(line[6:72] for line in source.splitlines() if len(line) > 6 and line[6] not in "*/") + m = re.search(r"\bENTRY\s+['\"]DLITCBL['\"]\s*(?:USING\s+(.*?))?\.", code, re.I | re.S) + if not m: + return None + words = [w.upper() for w in (m.group(1) or "").split()] + return [w for w in words if w not in ("BY", "REFERENCE")] + + +def stage(case: dict[str, Any], corpus: Path, source: str, dest: Path) -> list[dict[str, Any]]: + """Write dbd.cfg, psb.cfg and the seeds into `dest` (both sides read them); the PSB's DB PCBs.""" + dbds, pcbs = definitions(case, corpus) + using = entry_using(source) + if using is None: + raise Unsupported(f"{case['program']}: no ENTRY 'DLITCBL' (a BMP / MPP or CICS DL/I program is not modelled)") + if len(using) != len(pcbs): + raise Unsupported(f"{case['program']}: ENTRY 'DLITCBL' names {len(using)} PCBs, the PSB has {len(pcbs)}") + dest.mkdir(parents=True, exist_ok=True) + dbd_cfg, psb_cfg = config(dbds, pcbs) + (dest / "dbd.cfg").write_text(dbd_cfg, encoding="ascii") + (dest / "psb.cfg").write_text(psb_cfg, encoding="ascii") + for name, db in dbds.items(): + (dest / f"seed.{name}").write_bytes(seed(case, corpus, name, db)) + return pcbs + + +def cobol_driver(program_entry: str, pcbs: list[dict[str, Any]]) -> list[str]: + """The driver's lines: each PCB an area of its own, bound (GGDLINIT), the program entered at `program_entry` + with them, the databases written (GGDLIEND) -- the step's RETURN-CODE kept across that last CALL.""" + areas = [f"PCB-{i + 1}" for i in range(len(pcbs))] + using = " ".join(areas) + return [ + "IDENTIFICATION DIVISION.", "PROGRAM-ID. EQDRIVER.", "DATA DIVISION.", "WORKING-STORAGE SECTION.", + *[f"01 {a} PIC X({AREA}) VALUE LOW-VALUES." for a in areas], + "01 GG-RC PIC S9(9) COMP-5.", + "PROCEDURE DIVISION.", f" CALL 'GGDLINIT' USING {using}", f" CALL '{program_entry}' USING {using}", + " MOVE RETURN-CODE TO GG-RC", " CALL 'GGDLIEND'", " MOVE GG-RC TO RETURN-CODE", " STOP RUN.", + ] # fmt: skip + + +def split(data: bytes, sizes: dict[str, int]) -> list[tuple[str, bytes]]: + """A database file (seed or output) as [(segment, data)].""" + out, i = [], 0 + while i + 8 <= len(data): + name = data[i : i + 8].decode("ascii").rstrip() + n = sizes.get(name) + if n is None: + raise ValueError(f"segment {name!r} at {i}: not in the DBD") + out.append((name, data[i + 8 : i + 8 + n])) + i += 8 + n + return out + + +def diff_db(case: dict[str, Any], corpus: Path, name: str, cobol: bytes, java: bytes) -> dict[str, Any]: + """One database on both sides: its segments paired in hierarchic sequence, each one's fields (its segment's + layout, else its bytes) compared.""" + dbds, _ = definitions(case, corpus) + sizes = {s["name"]: s["bytes"] for s in dbds[name]["segments"]} + left, right = split(cobol, sizes), split(java, sizes) + diffs: list[dict[str, Any]] = [] + enc = common.data_encoding(case) + for k in range(max(len(left), len(right))): + a = left[k] if k < len(left) else None + b = right[k] if k < len(right) else None + if a is None or b is None or a[0] != b[0]: + diffs.append({"segment": k + 1, "cobol": a[0] if a else None, "java": b[0] if b else None}) + continue + if a[1] == b[1]: + continue + layout = _layout(case, corpus, a[0]) + if layout is None: + diffs.append({"segment": k + 1, "name": a[0], "cobol": a[1].hex(), "java": b[1].hex()}) + continue + d = common.diff_records(a[1], b[1], len(a[1]), layout, case.get("code_page", "cp037"), enc) + diffs.append({"segment": k + 1, "name": a[0], "diffs": d["diffs"]}) + return {"records": max(len(left), len(right)), "diffs": diffs} diff --git a/tests/tools/equivalence_java.py b/tests/tools/equivalence_java.py index 235d929ea6..174b2aab91 100644 --- a/tests/tools/equivalence_java.py +++ b/tests/tools/equivalence_java.py @@ -721,6 +721,11 @@ def _run_area(case: dict[str, Any], project: Path, area: Path, inputs: Path, env sqlout = area / "out" / "sqlout.txt" sqlout.unlink(missing_ok=True) props = f"{props} -Dgitgalaxy.db2.sqllog={sqlout}" + if case.get("ims"): # #4893: the databases the COBOL side was given (equivalence_ims.stage), written back here + dliout = area / "out" / "dli" + shutil.rmtree(dliout, ignore_errors=True) + dliout.mkdir(parents=True) + props = f"{props} -Dgitgalaxy.dli.dir={inputs / 'dli'} -Dgitgalaxy.dli.out={dliout}" out = run_maven(project, area, inputs, env, f"{props} -Dgitgalaxy.sysout={sysout} {data_charset_arg(case)}".strip()) outs = {dd: out / f"{dd}.out" for dd, spec in case["datasets"].items() if spec.get("compare")} for extra in ("RETURN-CODE", "ABEND", "FAULTS"): @@ -732,6 +737,9 @@ def _run_area(case: dict[str, Any], project: Path, area: Path, inputs: Path, env if case["db2"].get("compare_sql"): sqlout = area / "out" / "sqlout.txt" read["SQL"] = sqlout.read_bytes() if sqlout.is_file() else b"" + for name in (case.get("ims") or {}).get("compare", []): # #4893: DetDli.leave's databases + f = area / "out" / "dli" / f"{name}.out" + read[f"IMS {name}"] = f.read_bytes() if f.is_file() else b"" for extra in ("RETURN-CODE", "ABEND"): # a code, not a record: whitespace is not data if extra in read: read[extra] = read[extra].strip() From aef4ca4e809f407cb84bf0e9146f927a4fd54312 Mon Sep 17 00:00:00 2001 From: squid-protocol Date: Fri, 16 Oct 2026 04:12:36 -0400 Subject: [PATCH 2/8] IMS level fixture: DBD, PSB, DLILVL and its expected output, written before either runtime ran it (Part of #4893) Co-Authored-By: Claude Opus 5.5 --- tests/equivalence/ims/fixture/DLILVL.cbl | 291 +++++++++++++++++++++ tests/equivalence/ims/fixture/LVLDBD.dbd | 18 ++ tests/equivalence/ims/fixture/LVLPSB.psb | 13 + tests/equivalence/ims/fixture/expected.txt | 51 ++++ 4 files changed, 373 insertions(+) create mode 100644 tests/equivalence/ims/fixture/DLILVL.cbl create mode 100644 tests/equivalence/ims/fixture/LVLDBD.dbd create mode 100644 tests/equivalence/ims/fixture/LVLPSB.psb create mode 100644 tests/equivalence/ims/fixture/expected.txt diff --git a/tests/equivalence/ims/fixture/DLILVL.cbl b/tests/equivalence/ims/fixture/DLILVL.cbl new file mode 100644 index 0000000000..c7469e85c3 --- /dev/null +++ b/tests/equivalence/ims/fixture/DLILVL.cbl @@ -0,0 +1,291 @@ + IDENTIFICATION DIVISION. + PROGRAM-ID. DLILVL. + * #4893 level fixture: every modelled DL/I call and status code on + * LVLDBD through PSB LVLPSB. Its expected output, expected.txt, was + * written from IBM's documentation before either runtime ran it; + * each step's comment cites the rule (register I1-I5). + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 W-STEP PIC 99 VALUE 0. + 01 W-LEN PIC 99. + 01 W-KFB PIC X(10). + 01 W-IO PIC X(14). + 01 IOA PIC X(20). + 01 IOA-EMP REDEFINES IOA. + 05 IO-EMPNO PIC X(4). + 05 IO-ENAME PIC X(10). + 05 IO-SAL PIC S9(5) COMP-3. + 05 FILLER PIC X(3). + 01 F-GU PIC X(4) VALUE 'GU '. + 01 F-GHU PIC X(4) VALUE 'GHU '. + 01 F-GN PIC X(4) VALUE 'GN '. + 01 F-GNP PIC X(4) VALUE 'GNP '. + 01 F-ISRT PIC X(4) VALUE 'ISRT'. + 01 F-REPL PIC X(4) VALUE 'REPL'. + 01 F-DLET PIC X(4) VALUE 'DLET'. + 01 F-BAD PIC X(4) VALUE 'XXXX'. + 01 S-DEPT PIC X(9) VALUE 'DEPT '. + 01 S-EMP PIC X(9) VALUE 'EMP '. + 01 S-SKILL PIC X(9) VALUE 'SKILL '. + 01 S-NOSEG PIC X(9) VALUE 'NOSEG '. + 01 Q-DEPT. + 05 FILLER PIC X(9) VALUE 'DEPT ('. + 05 FILLER PIC X(8) VALUE 'DEPTNO'. + 05 Q-DEPT-OP PIC X(2) VALUE 'EQ'. + 05 Q-DEPT-NO PIC X(4). + 05 Q-DEPT-END PIC X VALUE ')'. + 01 Q-EMP. + 05 FILLER PIC X(9) VALUE 'EMP ('. + 05 FILLER PIC X(8) VALUE 'EMPNO'. + 05 FILLER PIC X(2) VALUE ' ='. + 05 Q-EMP-NO PIC X(4). + 05 FILLER PIC X VALUE ')'. + 01 Q-SAL. + 05 FILLER PIC X(9) VALUE 'EMP ('. + 05 FILLER PIC X(8) VALUE 'SAL'. + 05 FILLER PIC X(2) VALUE '> '. + 05 Q-SAL-V PIC S9(5) COMP-3. + 05 FILLER PIC X VALUE ')'. + 01 Q-NAME. + 05 FILLER PIC X(9) VALUE 'EMP ('. + 05 FILLER PIC X(8) VALUE 'ENAME'. + 05 FILLER PIC X(2) VALUE 'EQ'. + 05 Q-NAME-V PIC X(10). + 05 FILLER PIC X VALUE ')'. + 01 Q-NOFLD. + 05 FILLER PIC X(9) VALUE 'EMP ('. + 05 FILLER PIC X(8) VALUE 'NOFIELD'. + 05 FILLER PIC X(2) VALUE 'EQ'. + 05 FILLER PIC X(4) VALUE 'E001'. + 05 FILLER PIC X VALUE ')'. + LINKAGE SECTION. + 01 PCB1. + 05 P1-DBD PIC X(8). + 05 P1-LEVEL PIC X(2). + 05 P1-STATUS PIC X(2). + 05 P1-PROCOPT PIC X(4). + 05 FILLER PIC S9(5) COMP. + 05 P1-SEGNAME PIC X(8). + 05 P1-KFBLEN PIC S9(5) COMP. + 05 P1-NSENS PIC S9(5) COMP. + 05 P1-KFB PIC X(10). + 01 PCB2. + 05 P2-DBD PIC X(8). + 05 P2-LEVEL PIC X(2). + 05 P2-STATUS PIC X(2). + 05 P2-PROCOPT PIC X(4). + 05 FILLER PIC S9(5) COMP. + 05 P2-SEGNAME PIC X(8). + 05 P2-KFBLEN PIC S9(5) COMP. + 05 P2-NSENS PIC S9(5) COMP. + 05 P2-KFB PIC X(10). + PROCEDURE DIVISION. + MAIN-PARA. + ENTRY 'DLITCBL' USING PCB1 PCB2. + * I4: the masks as IMS hands them over + MOVE P1-NSENS TO W-LEN + DISPLAY 'PCB1 ' P1-DBD ' ' P1-LEVEL ' [' P1-STATUS '] ' + P1-PROCOPT ' ' W-LEN + MOVE P2-NSENS TO W-LEN + DISPLAY 'PCB2 ' P2-DBD ' ' P2-LEVEL ' [' P2-STATUS '] ' + P2-PROCOPT ' ' W-LEN + MOVE 'D200' TO Q-DEPT-NO + * 01 GU qualified root (I1 blank) + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GU PCB1 IOA Q-DEPT + PERFORM SHOW1 + * 02 GNP under parentage D200: its first dependent + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GNP PCB1 IOA + PERFORM SHOW1 + * 03 GNP: the next dependent, a level down + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GNP PCB1 IOA + PERFORM SHOW1 + * 04 GNP: no more under D200: GE (I1); feedback the parent (I4) + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GNP PCB1 IOA + PERFORM SHOW1 + * 05 GN DEPT after GNP's GE: the next root (I3) + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GN PCB1 IOA S-DEPT + PERFORM SHOW1 + * 06 GN DEPT past the last root: GB (I1) + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GN PCB1 IOA S-DEPT + PERFORM SHOW1 + * 07 GN after GB starts again at the first root (I3) + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GN PCB1 IOA S-DEPT + PERFORM SHOW1 + * 08 unqualified GN down a level: blank + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GN PCB1 IOA + PERFORM SHOW1 + * 09 down again: blank + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GN PCB1 IOA + PERFORM SHOW1 + * 10 a twin: blank + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GN PCB1 IOA + PERFORM SHOW1 + * 11 up a level: GA (I1) + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GN PCB1 IOA + PERFORM SHOW1 + * 12 another type, same level: GK (I1) + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GN PCB1 IOA + PERFORM SHOW1 + * 13 up to the next root: GA + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GN PCB1 IOA + PERFORM SHOW1 + MOVE 'D100' TO Q-DEPT-NO + MOVE 'E002' TO Q-EMP-NO + * 14 GU along a qualified path + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GU PCB1 IOA Q-DEPT Q-EMP + PERFORM SHOW1 + MOVE +1500 TO Q-SAL-V + * 15 GU on a P search field, > (I2) + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GU PCB1 IOA Q-DEPT Q-SAL + PERFORM SHOW1 + MOVE 'ZED' TO Q-NAME-V + * 16 GU not found: GE, the deepest level satisfied (I4) + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GU PCB1 IOA Q-DEPT Q-NAME + PERFORM SHOW1 + MOVE 'E003' TO Q-EMP-NO + * 17 an unqualified level is any occurrence + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GU PCB1 IOA S-DEPT Q-EMP + PERFORM SHOW1 + * 18 GNP SKILL under E003 + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GNP PCB1 IOA S-SKILL + PERFORM SHOW1 + * 19 none left: GE + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GNP PCB1 IOA S-SKILL + PERFORM SHOW1 + MOVE 'D100' TO Q-DEPT-NO + * 20 GU D100 + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GU PCB1 IOA Q-DEPT + PERFORM SHOW1 + MOVE 'E005EVE' TO IOA + MOVE +5000 TO IO-SAL + * 21 ISRT along a path: among its twins by key + CALL 'CBLTDLI' USING F-ISRT PCB1 IOA Q-DEPT S-EMP + PERFORM SHOW1 + * 22 the same key again: II (I1) + CALL 'CBLTDLI' USING F-ISRT PCB1 IOA Q-DEPT S-EMP + PERFORM SHOW1 + MOVE 'D999' TO Q-DEPT-NO + * 23 a parent not found: GE + CALL 'CBLTDLI' USING F-ISRT PCB1 IOA Q-DEPT S-EMP + PERFORM SHOW1 + MOVE 'D150NEW' TO IOA + * 24 ISRT a root + CALL 'CBLTDLI' USING F-ISRT PCB1 IOA S-DEPT + PERFORM SHOW1 + MOVE 'D100' TO Q-DEPT-NO + MOVE 'E001' TO Q-EMP-NO + * 25 GHU, then REPL the held segment + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GHU PCB1 IOA Q-DEPT Q-EMP + PERFORM SHOW1 + MOVE 'ALICIA' TO IO-ENAME + * 26 REPL: blank + CALL 'CBLTDLI' USING F-REPL PCB1 IOA + PERFORM SHOW1 + * 27 REPL with no get-hold just before: DJ + CALL 'CBLTDLI' USING F-REPL PCB1 IOA + PERFORM SHOW1 + MOVE 'E002' TO Q-EMP-NO + * 28 GHU E002 + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GHU PCB1 IOA Q-DEPT Q-EMP + PERFORM SHOW1 + MOVE 'E009' TO IO-EMPNO + * 29 REPL that changed the key: DA + CALL 'CBLTDLI' USING F-REPL PCB1 IOA + PERFORM SHOW1 + MOVE 'E001' TO Q-EMP-NO + * 30 GHU E001 + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GHU PCB1 IOA Q-DEPT Q-EMP + PERFORM SHOW1 + * 31 DLET: E001 and its skills + CALL 'CBLTDLI' USING F-DLET PCB1 IOA + PERFORM SHOW1 + * 32 E001 is gone: GE + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GU PCB1 IOA Q-DEPT Q-EMP + PERFORM SHOW1 + MOVE 'D777' TO IOA + * 33 ISRT under PROCOPT=G: AM (I1) + CALL 'CBLTDLI' USING F-ISRT PCB2 IOA S-DEPT + PERFORM SHOW2 + * 34 GNP with no parentage: GP (I1) + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GNP PCB2 IOA + PERFORM SHOW2 + * 35 an SSA naming no segment: AC (I1) + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GU PCB2 IOA S-NOSEG + PERFORM SHOW2 + * 36 an undefined field: AK + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GU PCB2 IOA S-DEPT Q-NOFLD + PERFORM SHOW2 + MOVE 'XX' TO Q-DEPT-OP + * 37 an invalid operator: AJ + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GU PCB2 IOA Q-DEPT + PERFORM SHOW2 + MOVE 'EQ' TO Q-DEPT-OP + MOVE 'X' TO Q-DEPT-END + * 38 no ')' to end the qualification: AJ + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GU PCB2 IOA Q-DEPT + PERFORM SHOW2 + MOVE ')' TO Q-DEPT-END + * 39 an invalid function: AD + CALL 'CBLTDLI' USING F-BAD PCB2 IOA + PERFORM SHOW2 + * 40 the whole database, as PCB 1 left it + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GU PCB2 IOA + PERFORM SHOW2 + PERFORM UNTIL P2-STATUS = 'GB' + MOVE SPACES TO IOA + CALL 'CBLTDLI' USING F-GN PCB2 IOA + PERFORM SHOW2 + END-PERFORM + GOBACK. + SHOW1. + ADD 1 TO W-STEP + MOVE P1-KFBLEN TO W-LEN + MOVE SPACES TO W-KFB + IF W-LEN > 0 + MOVE P1-KFB(1:W-LEN) TO W-KFB + END-IF + MOVE IOA(1:14) TO W-IO + DISPLAY W-STEP ' 1 [' P1-STATUS '] ' P1-LEVEL ' ' + P1-SEGNAME ' ' + W-LEN ' ' W-KFB ' ' W-IO. + SHOW2. + ADD 1 TO W-STEP + MOVE P2-KFBLEN TO W-LEN + MOVE SPACES TO W-KFB + IF W-LEN > 0 + MOVE P2-KFB(1:W-LEN) TO W-KFB + END-IF + MOVE IOA(1:14) TO W-IO + DISPLAY W-STEP ' 2 [' P2-STATUS '] ' P2-LEVEL ' ' + P2-SEGNAME ' ' + W-LEN ' ' W-KFB ' ' W-IO. diff --git a/tests/equivalence/ims/fixture/LVLDBD.dbd b/tests/equivalence/ims/fixture/LVLDBD.dbd new file mode 100644 index 0000000000..3c80b0c7a5 --- /dev/null +++ b/tests/equivalence/ims/fixture/LVLDBD.dbd @@ -0,0 +1,18 @@ +* #4893 level fixture: a three-level HIDAM database written for the DL/I model's level test (no estate's). +* DEPT (root) -- EMP -- SKILL, and DEPT -- PROJ: every child type order, three key types (C, X, P search). + DBD NAME=LVLDBD,ACCESS=(HIDAM,VSAM) + DATASET DD1=LVLDBD + SEGM NAME=DEPT,PARENT=0,BYTES=20 + FIELD NAME=(DEPTNO,SEQ,U),START=1,BYTES=4,TYPE=C + FIELD NAME=DNAME,START=5,BYTES=16,TYPE=C + SEGM NAME=EMP,PARENT=DEPT,BYTES=20 + FIELD NAME=(EMPNO,SEQ,U),START=1,BYTES=4,TYPE=C + FIELD NAME=ENAME,START=5,BYTES=10,TYPE=C + FIELD NAME=SAL,START=15,BYTES=3,TYPE=P + SEGM NAME=SKILL,PARENT=EMP,BYTES=8 + FIELD NAME=(SKCODE,SEQ,U),START=1,BYTES=2,TYPE=C + SEGM NAME=PROJ,PARENT=DEPT,BYTES=12 + FIELD NAME=(PROJNO,SEQ,U),START=1,BYTES=2,TYPE=X + DBDGEN + FINISH + END diff --git a/tests/equivalence/ims/fixture/LVLPSB.psb b/tests/equivalence/ims/fixture/LVLPSB.psb new file mode 100644 index 0000000000..43fbe0d3d0 --- /dev/null +++ b/tests/equivalence/ims/fixture/LVLPSB.psb @@ -0,0 +1,13 @@ +* #4893 level fixture: PCB 1 may do everything (PROCOPT=A), PCB 2 only read (PROCOPT=G), one database. +LVLPCB1 PCB TYPE=DB,DBDNAME=LVLDBD,PROCOPT=A,KEYLEN=10 + SENSEG NAME=DEPT,PARENT=0 + SENSEG NAME=EMP,PARENT=DEPT + SENSEG NAME=SKILL,PARENT=EMP + SENSEG NAME=PROJ,PARENT=DEPT +LVLPCB2 PCB TYPE=DB,DBDNAME=LVLDBD,PROCOPT=G,KEYLEN=10 + SENSEG NAME=DEPT,PARENT=0 + SENSEG NAME=EMP,PARENT=DEPT + SENSEG NAME=SKILL,PARENT=EMP + SENSEG NAME=PROJ,PARENT=DEPT + PSBGEN LANG=COBOL,PSBNAME=LVLPSB,CMPAT=NO + END diff --git a/tests/equivalence/ims/fixture/expected.txt b/tests/equivalence/ims/fixture/expected.txt new file mode 100644 index 0000000000..23b364ded9 --- /dev/null +++ b/tests/equivalence/ims/fixture/expected.txt @@ -0,0 +1,51 @@ +PCB1 LVLDBD 00 [ ] A 04 +PCB2 LVLDBD 00 [ ] G 04 +01 1 [ ] 01 DEPT 04 D200 D200OPS +02 1 [ ] 02 EMP 08 D200E003 E003CAROL +03 1 [ ] 03 SKILL 10 D200E003S1 S1DB2 +04 1 [GE] 01 DEPT 04 D200 +05 1 [ ] 01 DEPT 04 D300 D300HR +06 1 [GB] 01 DEPT 04 D300 +07 1 [ ] 01 DEPT 04 D100 D100SALES +08 1 [ ] 02 EMP 08 D100E001 E001ALICE +09 1 [ ] 03 SKILL 10 D100E001S1 S1COBOL +10 1 [ ] 03 SKILL 10 D100E001S2 S2JAVA +11 1 [GA] 02 EMP 08 D100E002 E002BOB +12 1 [GK] 02 PROJ 06 D100P1 P1ALPHA +13 1 [GA] 01 DEPT 04 D200 D200OPS +14 1 [ ] 02 EMP 08 D100E002 E002BOB +15 1 [ ] 02 EMP 08 D100E002 E002BOB +16 1 [GE] 01 DEPT 04 D100 +17 1 [ ] 02 EMP 08 D200E003 E003CAROL +18 1 [ ] 03 SKILL 10 D200E003S1 S1DB2 +19 1 [GE] 02 EMP 08 D200E003 +20 1 [ ] 01 DEPT 04 D100 D100SALES +21 1 [ ] 02 EMP 08 D100E005 E005EVE +22 1 [II] 01 DEPT 04 D100 E005EVE +23 1 [GE] 00 00 E005EVE +24 1 [ ] 01 DEPT 04 D150 D150NEW +25 1 [ ] 02 EMP 08 D100E001 E001ALICE +26 1 [ ] 02 EMP 08 D100E001 E001ALICIA +27 1 [DJ] 02 EMP 08 D100E001 E001ALICIA +28 1 [ ] 02 EMP 08 D100E002 E002BOB +29 1 [DA] 02 EMP 08 D100E002 E009BOB +30 1 [ ] 02 EMP 08 D100E001 E001ALICIA +31 1 [ ] 02 EMP 08 D100E001 E001ALICIA +32 1 [GE] 01 DEPT 04 D100 +33 2 [AM] 00 00 D777 +34 2 [GP] 00 00 +35 2 [AC] 00 00 +36 2 [AK] 00 00 +37 2 [AJ] 00 00 +38 2 [AJ] 00 00 +39 2 [AD] 00 00 +40 2 [ ] 01 DEPT 04 D100 D100SALES +41 2 [ ] 02 EMP 08 D100E002 E002BOB +42 2 [ ] 02 EMP 08 D100E005 E005EVE +43 2 [GK] 02 PROJ 06 D100P1 P1ALPHA +44 2 [GA] 01 DEPT 04 D150 D150NEW +45 2 [ ] 01 DEPT 04 D200 D200OPS +46 2 [ ] 02 EMP 08 D200E003 E003CAROL +47 2 [ ] 03 SKILL 10 D200E003S1 S1DB2 +48 2 [GA] 01 DEPT 04 D300 D300HR +49 2 [GB] 01 DEPT 04 D300 From 306e0f49f09139675a3f355a0e4148350609ddb8 Mon Sep 17 00:00:00 2001 From: squid-protocol Date: Fri, 16 Oct 2026 04:16:28 -0400 Subject: [PATCH 3/8] IMS DL/I: register family I, DLI rule family, ACCEPT FROM DATE, tests; level fixture passes on both runtimes (Part of #4893) Co-Authored-By: Claude Opus 5.5 --- docs/language_status/cobolrt_rules.json | 233 ++++++++++++ docs/language_status/register/I1.md | 35 ++ docs/language_status/register/I2.md | 23 ++ docs/language_status/register/I3.md | 26 ++ docs/language_status/register/I4.md | 25 ++ docs/language_status/register/I5.md | 31 ++ docs/language_status/register/I6.md | 22 ++ docs/language_status/register/_layout.json | 4 + .../register/_parts/11a-ims-dl-i-ggdli-c.md | 1 + .../cobol_to_java/det/cobolrt/Funcs.java | 21 ++ .../cobol_to_java/det/cobolrt/dli/DetDli.java | 1 - gitgalaxy/tools/cobol_to_java/det/gen.py | 7 +- tests/cobol_mainframe/test_det_dli.py | 333 ++++++++++++++++++ tests/cobol_mainframe/test_det_source_4462.py | 5 +- .../test_evidence_components.py | 6 +- tests/tools/equivalence.py | 2 +- tests/tools/equivalence_ims.py | 3 +- tests/tools/evidence.py | 25 +- tests/tools/statement_inventory.py | 3 +- 19 files changed, 790 insertions(+), 16 deletions(-) create mode 100644 docs/language_status/register/I1.md create mode 100644 docs/language_status/register/I2.md create mode 100644 docs/language_status/register/I3.md create mode 100644 docs/language_status/register/I4.md create mode 100644 docs/language_status/register/I5.md create mode 100644 docs/language_status/register/I6.md create mode 100644 docs/language_status/register/_parts/11a-ims-dl-i-ggdli-c.md create mode 100644 tests/cobol_mainframe/test_det_dli.py diff --git a/docs/language_status/cobolrt_rules.json b/docs/language_status/cobolrt_rules.json index 37920f545e..5c16582516 100644 --- a/docs/language_status/cobolrt_rules.json +++ b/docs/language_status/cobolrt_rules.json @@ -34,6 +34,15 @@ }, "carddemo-cobdatft": { "title": "CardDemo app/asm/COBDATFT.asm -- the estate's own assembler routine (no IBM manual applies; the source is the reference)" + }, + "ims-apis": { + "title": "IBM IMS Application Programming APIs (DL/I calls, SSAs, relational operators)" + }, + "ims-ap": { + "title": "IBM IMS Application Programming (DB PCB masks, current position in the database)" + }, + "ims-codes": { + "title": "IBM IMS Messages and Codes, Volume 4: IMS Component Codes (DL/I status codes)" } }, "options": { @@ -214,6 +223,32 @@ "about": "The date / time services and COBDATFT, as the harness's C models do them.", "plumbing": [] }, + { + "id": "DLI", + "prefix": "DLI", + "title": "IMS DL/I database calls", + "files": [ + "dli/DetDli.java" + ], + "done": true, + "about": "A batch DL/I program's CALL 'CBLTDLI' through a DB PCB on a stated database: the twin of the harness's ggdli.c (register family I).", + "plumbing": [ + "refuse", + "dir", + "name8", + "findSeg", + "findFld", + "keyCmp", + "keyAt", + "fullword", + "text", + "dbFirst", + "descends", + "descendsType", + "lastInSubtree", + "ancestorOfType" + ] + }, { "id": "DATA", "prefix": "DATA", @@ -1869,6 +1904,22 @@ "status": "MATCHED", "calibration": "uncalibrated" }, + { + "id": "RT-FUNC-ACCEPT-DATE", + "family": "FUNC", + "title": "ACCEPT FROM DATE / DATE YYYYMMDD / DAY / DAY YYYYDDD / TIME: the run's clock as the unsigned integer item IBM describes, moved as that item", + "methods": [ + "accept" + ], + "ibm": { + "doc": "cobol-lr", + "section": "ACCEPT statement: Format 2 (system date and time)" + }, + "options": [], + "register": [], + "status": "MATCHED", + "calibration": "uncalibrated" + }, { "id": "RT-CICS-POINTER-IN-COMMAREA", "family": "CICS", @@ -2851,6 +2902,188 @@ "status": "MATCHED", "calibration": "uncalibrated" }, + { + "id": "RT-DLI-ENTRY", + "family": "DLI", + "title": "ENTRY 'DLITCBL': each DB PCB of the PSB bound to the area IMS passes, its mask filled (DBD name, level 00, blank status, PROCOPT, sensitive segments, key feedback zero)", + "methods": [ + "enter" + ], + "ibm": { + "doc": "ims-ap", + "section": "Specifying the DB PCB mask" + }, + "options": [], + "register": [ + "I4" + ], + "status": "ASSUMED", + "calibration": "uncalibrated" + }, + { + "id": "RT-DLI-STATE", + "family": "DLI", + "title": "The stated database: DBD / PSB configuration and seed loaded in hierarchic sequence (refused when out of order), new twins placed by segment type and sequence field, each database written at the step's end", + "methods": [ + "load", + "loadDb", + "linkChild", + "leave", + "dump" + ], + "ibm": { + "doc": "ims-ap", + "section": "Hierarchic sequence" + }, + "options": [], + "register": [ + "I1", + "I2", + "I6" + ], + "status": "ASSUMED", + "calibration": "uncalibrated" + }, + { + "id": "RT-DLI-SSA", + "family": "DLI", + "title": "SSAs: segment name, unqualified (blank) or qualified (field, relational operator, value, ')'); AC / AJ / AK as IBM answers them; command codes, boolean qualification and missing levels refused", + "methods": [ + "parseSsas", + "chain" + ], + "ibm": { + "doc": "ims-apis", + "section": "Segment search arguments (SSAs)" + }, + "options": [], + "register": [ + "I1", + "I5" + ], + "status": "ASSUMED", + "calibration": "uncalibrated" + }, + { + "id": "RT-DLI-QUALIFY", + "family": "DLI", + "title": "A qualification compares the field's stored bytes (C / X); a P field only where packed and logical comparison agree (both valid, one positive sign)", + "methods": [ + "qualifies", + "packedSign", + "satisfies" + ], + "ibm": { + "doc": "ims-apis", + "section": "SSA relational operators" + }, + "options": [], + "register": [ + "I2" + ], + "status": "DIFFERS", + "calibration": "uncalibrated" + }, + { + "id": "RT-DLI-FEEDBACK", + "family": "DLI", + "title": "The PCB mask after a call: status code, segment level, segment name, concatenated key and its length", + "methods": [ + "feedback", + "status" + ], + "ibm": { + "doc": "ims-ap", + "section": "Specifying the DB PCB mask" + }, + "options": [], + "register": [ + "I4" + ], + "status": "ASSUMED", + "calibration": "uncalibrated" + }, + { + "id": "RT-DLI-GET", + "family": "DLI", + "title": "GU / GN / GNP and their holds: the first segment in hierarchic sequence satisfying the SSAs, from the database's start, from position, or under parentage; GE / GB / GP / GA / GK; position and parentage after the call", + "methods": [ + "get", + "firstSatisfying", + "deepest", + "nextInSeq" + ], + "ibm": { + "doc": "ims-apis", + "section": "GU / GHU, GN / GHN, GNP / GHNP calls" + }, + "options": [], + "register": [ + "I1", + "I3" + ], + "status": "ASSUMED", + "calibration": "uncalibrated" + }, + { + "id": "RT-DLI-ISRT", + "family": "DLI", + "title": "ISRT: the segment under the parent its SSAs (or current position) locate, among its twins by sequence field; II for a key its twins hold, GE for a parent not found", + "methods": [ + "isrt" + ], + "ibm": { + "doc": "ims-apis", + "section": "ISRT call" + }, + "options": [], + "register": [ + "I1", + "I3" + ], + "status": "ASSUMED", + "calibration": "uncalibrated" + }, + { + "id": "RT-DLI-CHANGE", + "family": "DLI", + "title": "REPL / DLET on the segment the previous get-hold call returned; DJ without one, DA when the I/O area changed the sequence field; DLET removes the segment's dependents", + "methods": [ + "change" + ], + "ibm": { + "doc": "ims-apis", + "section": "REPL call; DLET call" + }, + "options": [], + "register": [ + "I1", + "I3" + ], + "status": "ASSUMED", + "calibration": "uncalibrated" + }, + { + "id": "RT-DLI-CALL", + "family": "DLI", + "title": "CALL 'CBLTDLI' USING function pcb io-area [ssa ...]: the PCB the program was passed, the function's dispatch (AD for an unknown function, AM for one PROCOPT does not allow), any other DL/I call refused", + "methods": [ + "call", + "findPcb", + "allows" + ], + "ibm": { + "doc": "ims-codes", + "section": "DL/I status codes" + }, + "options": [], + "register": [ + "I1", + "I5" + ], + "status": "ASSUMED", + "calibration": "uncalibrated" + }, { "id": "RT-DATA-BINARY-SIZE", "family": "DATA", diff --git a/docs/language_status/register/I1.md b/docs/language_status/register/I1.md new file mode 100644 index 0000000000..93ad7f46f3 --- /dev/null +++ b/docs/language_status/register/I1.md @@ -0,0 +1,35 @@ +--- +id: "I1" +family: "I" +status: "ASSUMED" +title: "DL/I database calls through a DB PCB — the stated database model" +area: "IMS" +summary: "CBLTDLI GU GHU GN GHN GNP GHNP ISRT REPL DLET on a stated hierarchy (DBD / PSB sources, a seed), status codes from IBM's table, RETURN-CODE 0 after each call" +reached: "yes (CardDemo PAUDBUNL, carddemo-paudbunl, #4893)" +--- +- **What is modelled** (#4893). A batch DL/I program: IMS enters it at ENTRY 'DLITCBL' with the PSB's DB PCBs (CMPAT=NO, + a DLI region), and it issues `CALL 'CBLTDLI' USING function pcb io-area [ssa ...]`. The COBOL side runs against + `tests/equivalence/ims/ggdli.c`, the det port against `cobolrt/dli/DetDli.java`: one rule set, one set of refusals. + The calls are GU, GHU, GN, GHN, GNP, GHNP, ISRT, REPL and DLET (IBM IMS Application Programming APIs, "DL/I calls + for database management"). +- **The database is stated, not connected.** The case names its DBD and PSB sources, which the engine's own macro + reader parses (`gitgalaxy/core/ims_gen.py`), and a seed: the corpus's own HD unload (I6), or segments the case writes. + Both sides read the same `dbd.cfg` / `psb.cfg` / `seed.`, and each writes the database it ended with. The + harness compares those segment by segment, every field of the segment's copybook layout (`equivalence_ims.diff_db`). + The database is a hierarchy in hierarchic sequence: each parent's children by segment type in DBD order, and twins in + sequence-field order (I2). HIDAM, PHIDAM, HISAM and SHISAM are read alike. The HIDAM index is not a database here: + it only orders the roots by key, which the hierarchy already does. +- **Status codes** (IMS Messages and Codes, Volume 4, "DL/I status codes"): + - blank: success. + - GA: an unqualified GN / GNP moved up a level. GK: it returned a segment of another type at the same level. + - GE: segment not found, or ISRT's parent not found. GB: GN reached the end of the database. + - GP: GNP with no parentage. II: ISRT of a segment whose key its twins already hold. + - DJ: REPL / DLET without a get-hold call just before. DA: REPL / DLET whose I/O area changed the sequence field. + - AC: SSA naming a segment the DBD lacks, or SSAs out of hierarchic order. AJ: invalid SSA (qualification start, + operator, end). AK: invalid field name. AD: invalid function. AM: function the PCB's PROCOPT does not allow. + + Any other condition is refused (I5). +- **RETURN-CODE after the call.** Each call returns 0: the C model returns 0 (GnuCOBOL stores it in RETURN-CODE), and + the det port stores 0. IBM does not document what the DL/I language interface leaves in register 15 for a COBOL + CALL. A program that reads RETURN-CODE after a DL/I call, or ends without setting it, relies on this assumption: + PAUDBUNL ends RETURN-CODE 0 after its last GN (GB). diff --git a/docs/language_status/register/I2.md b/docs/language_status/register/I2.md new file mode 100644 index 0000000000..e5abf7642c --- /dev/null +++ b/docs/language_status/register/I2.md @@ -0,0 +1,23 @@ +--- +id: "I2" +family: "I" +status: "DIFFERS" +title: "Sequence-field order and SSA comparison — the stored bytes, in the data page" +area: "IMS" +summary: "twins and qualifications compare the field's stored bytes; a C / X key's order is the data page's (ASCII on both sides), not EBCDIC's; a P qualification only where packed and logical comparison agree" +reached: "no (CardDemo's keys are packed and binary bytes, the same in both pages)" +--- +- **Order.** Twins sit in the order of their sequence field's bytes, compared unsigned, on both sides. That is + IMS's own order for the bytes it holds. The corpus is evidence: CardDemo's unload of DBPAUTP0 (HIDAM, ACCNTID TYPE=P) + holds a root whose key is EBCDIC spaces (X'404040404040') after every valid packed key, which is a logical + comparison, not a packed one. A seed not in that order is refused: the oracle's byte order would not be the + estate's. +- **DIFFERS for text keys.** The harness's data page is ASCII-family (Latin-1), so a C key holding letters and digits + sorts in ASCII order on both sides, where z/OS sorts it in EBCDIC order (digits after letters). This is the + declared collation difference of indexed files (`COLLATION` in equivalence.py), here for twin order and for the GN / + GNP that walks it. No proven case reaches it. +- **Qualification** (IMS Application Programming APIs, "SSA: relational operators"). The operators are EQ, GT, LT, + GE, LE and NE, and their symbolic forms (`=`, `>`, `<`, `>=` / `=>`, `<=` / `=<`, `¬=` / `=¬`, each with a blank to + fill two bytes). A C or X field compares bytes. A P field compares arithmetically in IMS; the model compares bytes + only when both operands are valid packed numbers with the same positive sign (C or F), where the two comparisons + agree, and refuses otherwise by name. Any other field type in a qualification (Z, H, F, ...) is refused. diff --git a/docs/language_status/register/I3.md b/docs/language_status/register/I3.md new file mode 100644 index 0000000000..fdf2d6c9e5 --- /dev/null +++ b/docs/language_status/register/I3.md @@ -0,0 +1,26 @@ +--- +id: "I3" +family: "I" +status: "ASSUMED" +title: "Current position and parentage after each call" +area: "IMS" +summary: "position and parentage kept per PCB as IBM describes them; after a call whose position IBM leaves to IMS's search, the next call that needs it is refused" +reached: "yes (PAUDBUNL: GN after GNP's GE)" +--- +- **What is modelled** (IMS Application Programming, "Current position in the database after each call"). + - A successful GU, GN or GNP sets position on the segment it returned. GU and GN also set parentage there; GNP + leaves parentage alone. An unqualified GN continues from position in hierarchic sequence, and GNP stays under + the parent. + - GB sets position to the start of the database, so the next GN returns the first root. + - GNP's GE, when it walked the parent's dependents to their end (unqualified SSAs, or none), leaves parentage, and + leaves position past the parent's last dependent. PAUDBUNL relies on this: its next GN of a root continues from + there. + - ISRT sets position on the segment inserted. DLET sets position just before where the deleted segment was, so the + next GN goes on past it. REPL leaves position alone. A hold lasts until the next call on that PCB. +- **Left open, so refused.** IBM describes position after other unsuccessful calls in terms of IMS's own search: + after a GE from GU or ISRT, after II, or after a qualified GN / GNP that finds nothing, where the search stopped + depends on the access path. The model marks position (and, after GU, GN or ISRT, parentage) as open. A later + call that needs it (GN, GNP, an ISRT located by position) stops by name. The same applies after ISRT (parentage), + and on another PCB whose position or parentage a DLET removed. +- **Not settled.** Whether a qualified GN that finds nothing answers GE or GB depends on IMS's sequence-field search + (it may stop early at a key past the qualification): refused by name. diff --git a/docs/language_status/register/I4.md b/docs/language_status/register/I4.md new file mode 100644 index 0000000000..43540e1b32 --- /dev/null +++ b/docs/language_status/register/I4.md @@ -0,0 +1,25 @@ +--- +id: "I4" +family: "I" +status: "ASSUMED" +title: "The DB PCB mask — layout from IBM, the initial contents and an unsuccessful call's feedback assumed" +area: "IMS" +summary: "DBD name, level, status, PROCOPT, segment name, key feedback length, sensitive segments, key feedback as IBM lays them out; what IMS leaves there at entry and after GE / II assumed" +reached: "yes (PAUDBUNL tests PAUT-PCB-STATUS; its key feedback is only DISPLAYed on a path no scenario takes)" +--- +- **Layout** (IMS Application Programming, "Specifying the DB PCB mask"): + - DBD name (8 bytes), segment level (2 characters), status code (2), processing options (4), reserved (fullword) + - segment name (8), key feedback length (fullword), number of sensitive segments (fullword), key feedback area +- **No IBM copybook ships.** Neither the PCB mask macro nor an IBM copybook does. The program's own mask, CardDemo's + PAUTBPCB, is the estate's copybook, and the harness builds the area IMS would pass from the PSB (36 bytes and its + KEYLEN). +- **Assumed.** + - At entry the mask holds the DBD name, level `00`, status blank, the PCB's PROCOPT, reserved 0, a blank segment + name, key feedback length 0, the number of sensitive segments, and X'00' through the key feedback area. Every byte + past it that the program's mask names is X'00' too: z/OS has the PCB control block there, which no program should + read. + - A successful get or ISRT sets the level, segment name and concatenated key of the segment, and the key feedback + length. Bytes past that length keep what they held. + - A GE from GU or ISRT gives the deepest segment along the SSAs' path that IMS could satisfy (level `00`, a blank + name and length 0 when none could). GNP's GE gives its parent, and II gives the parent of the segment ISRT tried + to insert. GB, REPL and DLET leave level, name and key feedback as they were. diff --git a/docs/language_status/register/I5.md b/docs/language_status/register/I5.md new file mode 100644 index 0000000000..4e02931a14 --- /dev/null +++ b/docs/language_status/register/I5.md @@ -0,0 +1,31 @@ +--- +id: "I5" +family: "I" +status: "REFUSED" +title: "DL/I beyond the modelled calls — REFUSED" +area: "IMS" +summary: "EXEC DLI, BMP / MPP / CICS DL/I programs, I/O and GSAM PCBs, other calls (CHKP, XRST, ROLB, ...), command codes, boolean SSAs, AIBTDLI / CEETDLI, HDAM order, secondary indexes, logical relationships, load mode" +reached: "—" +--- +- **Refused by the det translator.** + - EXEC DLI stays a hole by name. + - CALL 'CBLTDLI' is refused in a program IMS does not enter at ENTRY 'DLITCBL' (a BMP, MPP or CICS program). + - Also refused: the parameter-count form (a binary count first), a PCB the entry was not passed, any ON EXCEPTION + phrase, and CALL 'AIBTDLI' or 'CEETDLI'. +- **Refused by the harness** (`equivalence_ims.Unsupported`, "not runnable faithfully"): + - HDAM and PHDAM: the root sequence is the randomizer's. + - GSAM, INDEX and LOGICAL databases. + - Logical relationships, variable-length segments, a non-unique or missing sequence field. + - CMPAT=YES (IMS passes an I/O PCB first: IMS TM), and an I/O, alternate or GSAM PCB. + - PROCSEQ (a secondary index), PROCOPT L / LS (load mode), a segment-level PROCOPT, and a PCB not sensitive to every + segment. + - An ENTRY 'DLITCBL' that does not name one area per PCB. +- **Refused by both runtimes at run time** ("CBLTDLI: ... is not modelled"; exit 98 on the COBOL side): + - Any DL/I call but the nine modelled ones (CHKP, XRST, ROLB, SYNC, LOG, STAT, GSCD, FLD, POS, INQY, PCB, TERM and + the message calls). + - An SSA with command codes, and boolean qualification. + - SSAs that leave out a level (a GU or path ISRT not starting at the root, or a gap between two SSAs). + - REPL / DLET with SSAs, an ISRT with no SSA or a qualified last SSA, and get-hold under PROCOPT O. + - The open-position cases of I3 and the comparisons of I2. + + An unknown function code is AD, as IBM answers it. diff --git a/docs/language_status/register/I6.md b/docs/language_status/register/I6.md new file mode 100644 index 0000000000..bc813c4e71 --- /dev/null +++ b/docs/language_status/register/I6.md @@ -0,0 +1,22 @@ +--- +id: "I6" +family: "I" +status: "ASSUMED" +title: "The corpus's HD unload read as a seed — its record layout observed, checked against its trailer" +area: "IMS" +summary: "an HD reorganization unload (DFSURGU0) read by the record layout observed in CardDemo's; the segment counts its trailer records must match what was read" +reached: "yes (carddemo-paudbunl: 22 roots, 202 children)" +--- +- **What.** CardDemo ships its pending-authorization database as an HD reorganization unload + (`data/EBCDIC/AWS.M2.CARDDEMO.IMSDATA.DBPAUTP0.dat`). The harness reads it as the case's seed: + - Each record starts with a halfword length and a halfword of zeros, then the segment level and flag bytes. + - The segment's length (halfword) is at offset 8 and its name (8 bytes, EBCDIC) at offset 10. + - Its data is the `length` bytes before the record's last byte. + - The first record is the header and the last the trailer. + - Each segment is laid out by its copybook into the case's data page: text through CCSID 037, COMP / COMP-3 bytes as + they are. +- **Assumed, and checked.** IBM documents the utility, not this record layout byte by byte. The layout above is the + one observed. It is checked twice. The trailer's per-segment counts (a fullword 32 bytes after each segment name) + must equal the segments read, 22 roots and 202 children. And every root's key and every child's two packed fields + must decode as valid packed numbers, except one root whose key is spaces (I2). A file that does not match is refused, + never seeded. diff --git a/docs/language_status/register/_layout.json b/docs/language_status/register/_layout.json index ca040c7d28..942eac2ab2 100644 --- a/docs/language_status/register/_layout.json +++ b/docs/language_status/register/_layout.json @@ -45,6 +45,10 @@ "part": "11-db2-equivalence-sql-py-ggsql-c.md", "family": "Q" }, + { + "part": "11a-ims-dl-i-ggdli-c.md", + "family": "I" + }, { "part": "12-the-java-side.md", "family": "J" diff --git a/docs/language_status/register/_parts/11a-ims-dl-i-ggdli-c.md b/docs/language_status/register/_parts/11a-ims-dl-i-ggdli-c.md new file mode 100644 index 0000000000..e1eab56931 --- /dev/null +++ b/docs/language_status/register/_parts/11a-ims-dl-i-ggdli-c.md @@ -0,0 +1 @@ +## IMS DL/I (`equivalence_ims.py`, `ggdli.c`, `DetDli`) diff --git a/gitgalaxy/tools/cobol_to_java/det/cobolrt/Funcs.java b/gitgalaxy/tools/cobol_to_java/det/cobolrt/Funcs.java index d9536b7654..0e102ed31d 100644 --- a/gitgalaxy/tools/cobol_to_java/det/cobolrt/Funcs.java +++ b/gitgalaxy/tools/cobol_to_java/det/cobolrt/Funcs.java @@ -124,6 +124,27 @@ public static String currentDate(java.time.LocalDateTime now) { + String.format(java.util.Locale.ROOT, "%02d", now.getNano() / 10_000_000) + "+0000"; } + /** ACCEPT identifier FROM DATE / DATE YYYYMMDD / DAY / DAY YYYYDDD / TIME (#4893): the run's clock -- `currentDate`, + * FUNCTION CURRENT-DATE's YYYYMMDDhhmmsshh -- as the unsigned integer item IBM describes (YYMMDD, YYYYMMDD, + * YYDDD, YYYYDDD, hhmmsshh), which the ACCEPT moves to its target as a MOVE of that item would. */ + // [rule RT-FUNC-ACCEPT-DATE] + public static Field accept(String currentDate, String from) { + java.time.LocalDate d = java.time.LocalDate.of(Integer.parseInt(currentDate.substring(0, 4)), + Integer.parseInt(currentDate.substring(4, 6)), Integer.parseInt(currentDate.substring(6, 8))); + String doy = String.format(java.util.Locale.ROOT, "%03d", d.getDayOfYear()); + String digits; + switch (from) { + case "DATE": digits = currentDate.substring(2, 8); break; + case "DATE YYYYMMDD": digits = currentDate.substring(0, 8); break; + case "DAY": digits = currentDate.substring(2, 4) + doy; break; + case "DAY YYYYDDD": digits = currentDate.substring(0, 4) + doy; break; + case "TIME": digits = currentDate.substring(8, 16); break; + default: throw new UnsupportedOperationException("ACCEPT FROM " + from + " is not modelled"); + } + Storage s = Storage.of(digits.getBytes(java.nio.charset.StandardCharsets.ISO_8859_1)); + return Field.zoned(s, 0, digits.length(), 0, false, false, false); + } + /** FUNCTION RANDOM, one run unit's sequence (oracle_assumptions.md C12). IBM documents the interface only -- * argument-1 a seed, zero or a positive integer; a first reference with no argument-1 seeds zero; a reference * with no argument-1 takes the next number of the current sequence -- not the generator. This is GnuCOBOL diff --git a/gitgalaxy/tools/cobol_to_java/det/cobolrt/dli/DetDli.java b/gitgalaxy/tools/cobol_to_java/det/cobolrt/dli/DetDli.java index 6fa1031805..17640edec0 100644 --- a/gitgalaxy/tools/cobol_to_java/det/cobolrt/dli/DetDli.java +++ b/gitgalaxy/tools/cobol_to_java/det/cobolrt/dli/DetDli.java @@ -299,7 +299,6 @@ public static void enter(Field... areas) { } /** The step ended: each database, in hierarchic sequence (8-byte segment name, then its data), to gitgalaxy.dli.out. */ - // [rule RT-DLI-STATE] public static void leave() { String out = System.getProperty("gitgalaxy.dli.out"); if (out == null) { diff --git a/gitgalaxy/tools/cobol_to_java/det/gen.py b/gitgalaxy/tools/cobol_to_java/det/gen.py index 85d08d1bbc..1039ede864 100644 --- a/gitgalaxy/tools/cobol_to_java/det/gen.py +++ b/gitgalaxy/tools/cobol_to_java/det/gen.py @@ -1984,11 +1984,10 @@ def _statement(self, s: S.Stmt, ind: str) -> list[str]: return [c, *self.call(s, ind)] if k == "ACCEPT": frm = s.data["from"] - src = {"DATE": "Funcs.acceptDate(clock())", "DATE YYYYMMDD": "Funcs.acceptDate8(clock())", - "TIME": "Funcs.acceptTime(clock())", "DAY": "Funcs.acceptDay(clock())", - "DAY YYYYDDD": "Funcs.acceptDay7(clock())"}.get(frm) # fmt: skip - if src is None: + # #4893: the run's clock (FUNCTION CURRENT-DATE's) as the unsigned integer item IBM names (Funcs.accept) + if frm not in ("DATE", "DATE YYYYMMDD", "TIME", "DAY", "DAY YYYYDDD"): raise Untranslatable(f"ACCEPT FROM {frm}") + src = f"Funcs.accept({self.current_date_expr()}, {jstr(frm)})" return [c, f"{ind}Cobol.move({src}, {self.field_expr(s.data['target'])}, CS);"] if k == "STRING": return [c, *self.string(s, ind)] diff --git a/tests/cobol_mainframe/test_det_dli.py b/tests/cobol_mainframe/test_det_dli.py new file mode 100644 index 0000000000..eb854c6012 --- /dev/null +++ b/tests/cobol_mainframe/test_det_dli.py @@ -0,0 +1,333 @@ +"""#4893: IMS DL/I database calls (CALL 'CBLTDLI') on both runtimes -- the det translator (det/dli.py), the det runtime +(cobolrt/dli/DetDli.java) and the harness's COBOL-side model (tests/equivalence/ims/ggdli.c), register family I. + +The level fixture (tests/equivalence/ims/fixture: LVLDBD, LVLPSB, DLILVL and expected.txt, written from IBM's +documentation before either runtime ran it) issues every modelled call and status code; with EQUIVALENCE_E2E=1 both +runtimes run it and each must print expected.txt and leave the same database.""" + +from __future__ import annotations + +import os +import re +import shutil +import subprocess +import sys +from pathlib import Path + +import pytest + +ROOT = Path(__file__).resolve().parents[2] +sys.path.insert(0, str(ROOT / "tests" / "tools")) + +import equivalence_ims as ei # noqa: E402 + +FIXTURE = ROOT / "tests" / "equivalence" / "ims" / "fixture" +IMAGE = "gitgalaxy-gnucobol:3" +PKG = "p" # test_det_programs.PKG: its _batch_package writes the batch package there + + +def _jdk() -> Path | None: + home = os.environ.get("JDK_17") or os.environ.get("JAVA_HOME") + return Path(home) / "bin" if home and (Path(home) / "bin/javac").is_file() else None + + +E2E = pytest.mark.skipif(os.environ.get("EQUIVALENCE_E2E") != "1" or not shutil.which("docker") or _jdk() is None, + reason="needs EQUIVALENCE_E2E=1, Docker and a JDK 17 (JAVA_HOME / JDK_17)") # fmt: skip + + +def _segment(name: str, data: bytes) -> bytes: + return name.ljust(8).encode("ascii") + data + + +def _emp(no: str, name: str, sal: int) -> bytes: + return f"{no}{name:<10}".encode("latin-1") + bytes.fromhex(f"{sal:05d}C") + b" " + + +# the fixture's database: D100 (E001 with two skills, E002, project P1), D200 (E003 with one skill), D300 +SEED = b"".join([ + _segment("DEPT", b"D100SALES "), _segment("EMP", _emp("E001", "ALICE", 1000)), + _segment("SKILL", b"S1COBOL "), _segment("SKILL", b"S2JAVA "), _segment("EMP", _emp("E002", "BOB", 2000)), + _segment("PROJ", b"P1ALPHA "), _segment("DEPT", b"D200OPS "), + _segment("EMP", _emp("E003", "CAROL", 3000)), _segment("SKILL", b"S1DB2 "), + _segment("DEPT", b"D300HR "), +]) # fmt: skip + + +def _stage(dest: Path, seed: bytes = SEED) -> list[dict]: + db = ei.dbd((FIXTURE / "LVLDBD.dbd").read_text(encoding="latin-1"), "LVLDBD.dbd") + pcbs = ei.psb((FIXTURE / "LVLPSB.psb").read_text(encoding="latin-1"), "LVLPSB.psb", {db["name"]: db}) + dbd_cfg, psb_cfg = ei.config({db["name"]: db}, pcbs) + dest.mkdir(parents=True, exist_ok=True) + (dest / "dbd.cfg").write_text(dbd_cfg, encoding="ascii") + (dest / "psb.cfg").write_text(psb_cfg, encoding="ascii") + (dest / "seed.LVLDBD").write_bytes(seed) + return pcbs + + +def _lines(text: str) -> list[str]: + return [ln.rstrip() for ln in text.splitlines() if ln.strip()] + + +# ---- the harness's reading of DBD / PSB sources ------------------------------------------------------------------ +def test_the_fixtures_dbd_and_psb_become_the_configuration_both_sides_read(tmp_path): + pcbs = _stage(tmp_path) + assert (tmp_path / "dbd.cfg").read_text().splitlines() == [ + "DBD LVLDBD", "SEGM LVLDBD DEPT 0 20", "SEGM LVLDBD EMP DEPT 20", "SEGM LVLDBD SKILL EMP 8", + "SEGM LVLDBD PROJ DEPT 12", "FIELD LVLDBD DEPT DEPTNO 1 4 C S", "FIELD LVLDBD DEPT DNAME 5 16 C -", + "FIELD LVLDBD EMP EMPNO 1 4 C S", "FIELD LVLDBD EMP ENAME 5 10 C -", "FIELD LVLDBD EMP SAL 15 3 P -", + "FIELD LVLDBD SKILL SKCODE 1 2 C S", "FIELD LVLDBD PROJ PROJNO 1 2 X S", + ] # fmt: skip + assert (tmp_path / "psb.cfg").read_text().splitlines() == ["PCB LVLDBD A 10", "PCB LVLDBD G 10"] + assert [p["procopt"] for p in pcbs] == ["A", "G"] + + +DBD_HEAD = " DBD NAME=X,ACCESS=(HIDAM,VSAM)\n" +SEGM = " SEGM NAME=R,PARENT=0,BYTES=10\n" +KEY = " FIELD NAME=(K,SEQ,U),START=1,BYTES=2,TYPE=C\n" + + +@pytest.mark.parametrize( + "text, why", + [ + (DBD_HEAD.replace("HIDAM", "HDAM") + SEGM + KEY, "ACCESS=HDAM"), + (DBD_HEAD.replace("HIDAM,VSAM", "GSAM,BSAM") + SEGM + KEY, "ACCESS=GSAM"), + (DBD_HEAD + SEGM.replace("BYTES=10", "BYTES=(10,4)") + KEY, "variable-length"), + (DBD_HEAD + SEGM + KEY.replace("SEQ,U", "SEQ,M"), "non-unique sequence field"), + (DBD_HEAD + SEGM, "no sequence field"), + (DBD_HEAD + SEGM + KEY + " SEGM NAME=C,PARENT=((R,),(L,PHYSICAL,LDB)),BYTES=4\n" + KEY, + "logical relationship"), + ], +) # fmt: skip +def test_a_dbd_the_model_does_not_model_is_refused_by_name(text, why): + with pytest.raises(ei.Unsupported, match=re.escape(why)): + ei.dbd(text, "X.dbd") + + +PCB = "P1 PCB TYPE=DB,DBDNAME=X,PROCOPT=A,KEYLEN=2\n SENSEG NAME=R,PARENT=0\n" +GEN = " PSBGEN LANG=COBOL,PSBNAME=P,CMPAT=NO\n" + + +@pytest.mark.parametrize( + "text, why", + [ + (PCB + GEN.replace("CMPAT=NO", "CMPAT=YES"), "CMPAT=YES"), + ("IO PCB TYPE=TP,MODIFY=YES\n" + PCB + GEN, "TYPE=TP PCB"), + ("G PCB TYPE=GSAM,DBDNAME=X,PROCOPT=LS\n" + GEN, "TYPE=GSAM PCB"), + (PCB.replace("KEYLEN=2", "KEYLEN=2,PROCSEQ=XIDX") + GEN, "PROCSEQ"), + (PCB.replace("PROCOPT=A", "PROCOPT=L") + GEN, "load mode"), + (PCB.replace("PARENT=0", "PARENT=0,PROCOPT=G") + GEN, "segment-level PROCOPT"), + (PCB.replace("DBDNAME=X", "DBDNAME=Y") + GEN, "not one of the case's DBDs"), + ], +) # fmt: skip +def test_a_psb_the_model_does_not_model_is_refused_by_name(text, why): + db = ei.dbd(DBD_HEAD + SEGM + KEY + " SEGM NAME=C,PARENT=R,BYTES=4\n" + KEY, "X.dbd") + with pytest.raises(ei.Unsupported, match=re.escape(why)): + ei.psb(text, "P.psb", {"X": db}) + + +def test_a_pcb_not_sensitive_to_every_segment_is_refused(): + db = ei.dbd(DBD_HEAD + SEGM + KEY + " SEGM NAME=C,PARENT=R,BYTES=4\n" + KEY, "X.dbd") + with pytest.raises(ei.Unsupported, match="partial sensitivity"): + ei.psb(PCB + GEN, "P.psb", {"X": db}) + + +def test_entry_using_reads_the_dlitcbl_entry_only(): + src = "\n".join(" " * 7 + ln for ln in ["PROCEDURE DIVISION USING A B.", "MAIN.", + " ENTRY 'DLITCBL' USING BY REFERENCE A", " B.", " GOBACK."]) # fmt: skip + assert ei.entry_using(src) == ["A", "B"] + assert ei.entry_using(src.replace("DLITCBL", "OTHER")) is None + + +def _unload(segments: list[tuple[str, bytes, int]], counts: dict[str, int]) -> bytes: + """An HD unload as CardDemo's is laid out (register I6): header, segment records, trailer with counts.""" + def rec(level: int, name: str, body: bytes, length: int) -> bytes: + head = bytes(4) + bytes([level, 0x80]) + b"\x00\x23" + length.to_bytes(2, "big") + name.ljust(8).encode("cp037") + r = head + bytes(21) + body + b"\x00" + return len(r).to_bytes(2, "big") + r[2:] + + trailer = bytearray(b"\x00\x00\x00\x00\x00\x98\x00\x50") + for name, n in counts.items(): + trailer += name.ljust(8).encode("cp037") + bytes(24) + n.to_bytes(4, "big") + trailer[0:2] = len(trailer).to_bytes(2, "big") + header = bytearray(b"\x00\x18\x00\x00\x00\x80\x00\x50") + bytes(16) + return bytes(header) + b"".join(rec(lv, n, b, len(b)) for n, b, lv in segments) + bytes(trailer) + + +def test_an_hd_unload_is_read_and_checked_against_its_trailer(tmp_path): + f = tmp_path / "db.dat" + root, child = "D1".encode("cp037") + b"\x00\x1c", "AB".encode("cp037") + f.write_bytes(_unload([("ROOT", root, 1), ("KID", child, 2), ("KID", child, 2)], {"ROOT": 1, "KID": 2})) + assert ei.unload(f) == [("ROOT", root), ("KID", child), ("KID", child)] + f.write_bytes(_unload([("ROOT", root, 1), ("KID", child, 2)], {"ROOT": 1, "KID": 2})) + with pytest.raises(ei.Unsupported, match="1 KID segments read, the trailer counts 2"): + ei.unload(f) + f.write_bytes(b"\x00\x05abc") + with pytest.raises(ei.Unsupported, match="not an HD unload"): + ei.unload(f) + + +def test_an_ebcdic_segment_is_laid_out_into_the_data_page(): + layout = [{"offset": 0, "bytes": 3, "usage": None}, {"offset": 3, "bytes": 2, "usage": "COMP-3"}, + {"offset": 5, "bytes": 2, "usage": "BINARY"}] # fmt: skip + data = "A{1".encode("cp037") + b"\x12\x3c" + b"\x00\x40" + assert ei.from_ebcdic(data, layout, "latin-1") == b"A{1\x12\x3c\x00\x40" + + +def test_diff_db_pairs_segments_and_names_the_ones_that_differ(): + case = {"ims": {"dbd": [], "psb": ""}} + ei_definitions = ei.definitions + try: + ei.definitions = lambda c, corpus: ({"X": {"segments": [{"name": "R", "bytes": 2}, {"name": "C", "bytes": 1}]}}, []) + same = _segment("R", b"r1") + _segment("C", b"c") + assert ei.diff_db(case, ROOT, "X", same, same) == {"records": 2, "equal": 2, "filler_differs": 0, "diffs": []} + d = ei.diff_db(case, ROOT, "X", same, _segment("R", b"r2") + _segment("C", b"c")) + assert d["equal"] == 1 and d["diffs"] == [{"segment": 1, "name": "R", "cobol": "7231", "java": "7232"}] + d = ei.diff_db(case, ROOT, "X", same, _segment("R", b"r1")) + assert d["equal"] == 1 and d["diffs"] == [{"segment": 2, "cobol": "C", "java": None}] + finally: + ei.definitions = ei_definitions + + +# ---- the det translator ------------------------------------------------------------------------------------------ +LINKAGE = ["LINKAGE SECTION.", "01 PCB1.", " 05 P-DBD PIC X(8).", " 05 P-REST PIC X(38).", + "01 PCB2 PIC X(46)."] # fmt: skip +WS = ["WORKING-STORAGE SECTION.", "01 FN PIC X(4) VALUE 'GU '.", "01 CNT PIC S9(9) COMP VALUE 3.", + "01 IOA PIC X(20).", "01 SSA PIC X(9) VALUE 'DEPT '.", "01 SSAS.", " 05 SSA1 PIC X(9) OCCURS 2."] # fmt: skip + + +def _program(proc: list[str], entry: str | None = " ENTRY 'DLITCBL' USING PCB1 PCB2.", using: str = "") -> str: + lines = ["IDENTIFICATION DIVISION.", "PROGRAM-ID. DLIT.", "DATA DIVISION.", *WS, *LINKAGE, + f"PROCEDURE DIVISION{using}.", "MAIN-PARA.", *([entry] if entry else []), *proc, " GOBACK."] # fmt: skip + return "\n".join(" " * 7 + ln for ln in lines) + "\n" + + +def _translate(tmp_path: Path, src: str): + pytest.importorskip("tree_sitter_language_pack") + sys.path.insert(0, str(ROOT / "tests" / "cobol_mainframe")) + import test_det_programs as tdp + from gitgalaxy.tools.cobol_to_java.det import program as P + + (tmp_path / "DLIT.cbl").write_text(src) + project = tmp_path / "project" + tdp._batch_package(project / "src/main/java") + return P.translate(tmp_path / "DLIT.cbl", [], "public class DlitService {\n}\n", PKG, None, project) + + +@pytest.mark.parametrize("using", ["", " USING PCB1 PCB2", " USING PCB2"]) +def test_cbltdli_is_a_detdli_call_and_the_entry_binds_the_pcbs(tmp_path, using): + """IMS enters the program at DLITCBL (with its own USING list) whatever PROCEDURE DIVISION USING says; every + function, any number of SSAs; RETURN-CODE 0 after each call (I1).""" + r = _translate(tmp_path, _program([" CALL 'CBLTDLI' USING FN PCB1 IOA", " CALL 'CBLTDLI' USING FN PCB2 IOA SSA SSA1(2)"], + using=using)) # fmt: skip + assert not r.stats["holes"], r.stats["holes"] + java = r.java + assert re.search(r"DetDli\.enter\(\w+, \w+\);", java) + assert len(re.findall(r"DetDli\.call\(", java)) == 2 + assert re.search(r"DetDli\.call\(\w+, \w+, \w+, \w+, \w+\.at\(", java) + assert java.count("BigDecimal.ZERO, false, CS);") >= 2 + assert "DetDli.leave();" in java + assert "parmText" not in java # no PARM written over the first PCB + + +@pytest.mark.parametrize( + "proc, entry, why", + [ + ([" CALL 'CBLTDLI' USING FN PCB1 IOA"], None, "a program IMS does not enter at ENTRY 'DLITCBL'"), + ([" CALL 'CBLTDLI' USING CNT FN PCB1 IOA"], " ENTRY 'DLITCBL' USING PCB1 PCB2.", "parameter-count form"), + ([" CALL 'CBLTDLI' USING FN IOA IOA"], " ENTRY 'DLITCBL' USING PCB1 PCB2.", "not one IMS passed"), + ([" CALL 'CBLTDLI' USING FN PCB1"], " ENTRY 'DLITCBL' USING PCB1 PCB2.", "up to 15 SSAs expected"), + ([" CALL 'CBLTDLI' USING FN PCB1 'X'"], " ENTRY 'DLITCBL' USING PCB1 PCB2.", "BY REFERENCE expected"), + ([" CALL 'AIBTDLI' USING FN PCB1 IOA"], " ENTRY 'DLITCBL' USING PCB1 PCB2.", "through an AIB"), + ([" CALL 'CEETDLI' USING FN PCB1 IOA"], " ENTRY 'DLITCBL' USING PCB1 PCB2.", "Language Environment DL/I"), + ], +) # fmt: skip +def test_what_the_translator_does_not_model_is_a_hole_by_name(tmp_path, proc, entry, why): + r = _translate(tmp_path, _program(proc, entry=entry)) + assert len(r.stats["holes"]) == 1 and why in r.stats["holes"][0], r.stats["holes"] + + +# ---- the level fixture on both runtimes (the first-time number: PR body) ---------------------------------------------- +def _cobol_side(work: Path, seed: bytes = SEED) -> tuple[str, bytes]: + pcbs = _stage(work / "dli", seed) + (work / "dliout").mkdir() + src = work / "src" + src.mkdir() + shutil.copy(FIXTURE / "DLILVL.cbl", src / "DLILVL.cbl") + shutil.copy(ei.STUB, src / "ggdli.c") + (src / "EQDRIVER.cbl").write_text("\n".join(" " * 7 + ln for ln in ei.cobol_driver("DLITCBL", pcbs)) + "\n") + script = ("cobc -x -std=ibm -fsign=EBCDIC -o prog src/EQDRIVER.cbl src/DLILVL.cbl src/ggdli.c && " + "GGDLI_DIR=/w/dli GGDLI_OUT=/w/dliout ./prog") # fmt: skip + run = subprocess.run(["docker", "run", "--rm", "-v", f"{work}:/w", "-w", "/w", IMAGE, "sh", "-c", script], # noqa: S607 + capture_output=True, text=True, check=False) # fmt: skip + assert run.returncode == 0, run.stdout + run.stderr + return run.stdout, (work / "dliout" / "LVLDBD.out").read_bytes() + + +def _java_side(work: Path, seed: bytes = SEED) -> tuple[str, bytes]: + pytest.importorskip("tree_sitter_language_pack") + sys.path.insert(0, str(ROOT / "tests" / "cobol_mainframe")) + import test_det_programs as tdp + from gitgalaxy.tools.cobol_to_java.det import program as P + + _stage(work / "dli", seed) + (work / "dliout").mkdir() + project = work / "project" + tdp._batch_package(project / "src/main/java") + r = P.translate(FIXTURE / "DLILVL.cbl", [], "public class DlilvlService {\n}\n", PKG, None, project) + assert not r.stats["holes"], r.stats["holes"] + srcdir = work / "java" + java = r.java.replace("import org.springframework.stereotype.Service;\n", "").replace("@Service\n", "") + runtime = {k: v for k, v in P.runtime_files(PKG, batch=True).items() + if not k.startswith(("cobolrt/cics/", "cobolrt/sql/"))} # fmt: skip + for rel, text in [(f"service/{r.service}.java", java), *runtime.items()]: + (srcdir / PKG / rel).parent.mkdir(parents=True, exist_ok=True) + (srcdir / PKG / rel).write_text(text) + tdp._batch_package(srcdir) + rec = srcdir / PKG / "entity/vsam/CobolRecords.java" + rec.parent.mkdir(parents=True, exist_ok=True) + rec.write_text(f"package {PKG}.entity.vsam;\npublic final class CobolRecords {{\n public static java.nio.charset." + "Charset charset() {\n return java.nio.charset.StandardCharsets.ISO_8859_1;\n }\n}\n") # fmt: skip + b = f"{PKG}.batch" + (srcdir / "Main.java").write_text( + f"public class Main {{ public static void main(String[] a) {{ new {PKG}.service.{r.service}(" + f'new {b}.DatasetResolver("{work}"), new {b}.CobolFiles("", ""), new {b}.MainframeClock("", "UTC"))' + ".runBatch(java.util.List.of(), null); } }\n" + ) + jdk = _jdk() + subprocess.run([str(jdk / "javac"), "-encoding", "UTF-8", "-nowarn", "-d", str(work / "classes"), # noqa: S603 + *map(str, srcdir.rglob("*.java"))], check=True) # fmt: skip + run = subprocess.run([str(jdk / "java"), f"-Dgitgalaxy.dli.dir={work / 'dli'}", f"-Dgitgalaxy.dli.out={work / 'dliout'}", # noqa: S603 + "-cp", str(work / "classes"), "Main"], capture_output=True, text=True, encoding="latin-1", + check=True) # fmt: skip + return run.stdout, (work / "dliout" / "LVLDBD.out").read_bytes() + + +@E2E +def test_the_level_fixture_prints_what_ibm_documents_on_both_runtimes(tmp_path): + expected = _lines((FIXTURE / "expected.txt").read_text(encoding="latin-1")) + cobol_out, cobol_db = _cobol_side(tmp_path / "cobol") + java_out, java_db = _java_side(tmp_path / "java") + assert _lines(cobol_out) == expected + assert _lines(java_out) == expected + assert cobol_db == java_db + sizes = {"DEPT": 20, "EMP": 20, "SKILL": 8, "PROJ": 12} + keys = [(n, d[:4].decode("latin-1").strip()) for n, d in ei.split(cobol_db, sizes)] + assert keys == [("DEPT", "D100"), ("EMP", "E002"), ("EMP", "E005"), ("PROJ", "P1AL"), ("DEPT", "D150"), + ("DEPT", "D200"), ("EMP", "E003"), ("SKILL", "S1DB"), ("DEPT", "D300")] # fmt: skip + + +@E2E +@pytest.mark.parametrize( + "seed, why", + [ + (_segment("EMP", _emp("E001", "X", 1)), "a seed segment before its parent"), + (_segment("DEPT", b"D200".ljust(20)) + _segment("DEPT", b"D100".ljust(20)), "not in hierarchic sequence"), + (_segment("NOSEG", b"x"), "a seed segment the DBD does not define"), + ], +) # fmt: skip +def test_a_seed_out_of_sequence_is_refused_by_both_runtimes(tmp_path, seed, why): + with pytest.raises(AssertionError, match=re.escape(why)): + _cobol_side(tmp_path / "cobol", seed) + with pytest.raises(subprocess.CalledProcessError) as e: + _java_side(tmp_path / "java", seed) + assert why in (e.value.stderr or "") diff --git a/tests/cobol_mainframe/test_det_source_4462.py b/tests/cobol_mainframe/test_det_source_4462.py index 3a6a0da785..b30b9eb98f 100644 --- a/tests/cobol_mainframe/test_det_source_4462.py +++ b/tests/cobol_mainframe/test_det_source_4462.py @@ -530,8 +530,9 @@ def test_entry_dlitcbl_is_read_and_is_the_programs_entry(using): assert [s.kind for s in body] == ["ENTRY", "DISPLAY", "ENTRY", "GOBACK"] assert [s.line for s in body] == [11, 13, 14, 15] assert body[0].data["name"] == "DLITCBL" and [r.name for r in body[0].data["using"]] == ["PCB1", "PCB2"] - assert proc.using == (["PCB1", "PCB2"] if not using else ["PCB1"]) - assert body[0].data.get("first") is (True if not using else None) and not body[2].data.get("first") + # #4893: IMS enters a DL/I program at DLITCBL with that ENTRY's list, whatever PROCEDURE DIVISION USING says + assert proc.using == ["PCB1", "PCB2"] + assert body[0].data.get("first") is True and not body[2].data.get("first") @pytest.mark.parametrize( diff --git a/tests/cobol_mainframe/test_evidence_components.py b/tests/cobol_mainframe/test_evidence_components.py index 3b0bcee51a..b6c0134d3f 100644 --- a/tests/cobol_mainframe/test_evidence_components.py +++ b/tests/cobol_mainframe/test_evidence_components.py @@ -21,7 +21,9 @@ def _find(pred): return next(t for t in ev.targets() if pred(t)) -BATCH = _find(lambda t: t.kind == "batch" and not t.db2) +BATCH = _find(lambda t: t.kind == "batch" and not t.db2 and not t.ims) +# #4893: a batch DL/I case (none has a committed port yet: the batch one, as if it stated databases) +IMS = next((t for t in ev.targets() if t.ims), None) or ev.Target(**{**BATCH.__dict__, "key": "ims", "ims": True}) CALL = _find(lambda t: t.kind == "call") ONLINE = _find(lambda t: t.kind == "cics" and not t.db2 and not t.programs) DB2_ONLINE = _find(lambda t: t.kind == "cics" and t.db2) @@ -67,7 +69,7 @@ def test_the_components_partition_each_input(): """No file escapes: every file the whole-input fingerprint covers is in some component, so a change to it moves the component fingerprints of the targets that use that component (representatives of each kind, a crucible port among them, which uses everything it has).""" - reps = (CRUCIBLE, LINKING, DB2_ONLINE, ONLINE, BATCH, CALL) + reps = (CRUCIBLE, LINKING, DB2_ONLINE, ONLINE, BATCH, CALL, IMS) for name in ev.COMPONENT_INPUTS: every = {p for t in reps for p in ev._match(ev._files_now(), t.specs[name]["paths"], t.specs[name]["exclude"])} for path in sorted(every): diff --git a/tests/tools/equivalence.py b/tests/tools/equivalence.py index be8e8f32d4..75b7f8cb08 100644 --- a/tests/tools/equivalence.py +++ b/tests/tools/equivalence.py @@ -635,7 +635,7 @@ def compare_run(case: dict[str, Any], corpus: Path, cobol: dict[str, bytes], jav d = equivalence_ims.diff_db(case, corpus, name, cobol.get(f"IMS {name}", b""), java.get(f"IMS {name}", b"")) run["outputs"][f"IMS {name}"] = d if d["diffs"]: - why.append(f"IMS {name}: {d['records'] - len(d['diffs'])}/{d['records']} segments equal") + why.append(f"IMS {name}: {d['equal']}/{d['records']} segments equal") # #4507: what Db2 answered each side's statements (not a run with planned SQL faults: those are compared as # fired faults) if (case.get("db2") or {}).get("compare_sql") and not (fault or {}).get("sql_plan"): diff --git a/tests/tools/equivalence_ims.py b/tests/tools/equivalence_ims.py index 692feb03cc..577e9e93cf 100644 --- a/tests/tools/equivalence_ims.py +++ b/tests/tools/equivalence_ims.py @@ -315,4 +315,5 @@ def diff_db(case: dict[str, Any], corpus: Path, name: str, cobol: bytes, java: b continue d = common.diff_records(a[1], b[1], len(a[1]), layout, case.get("code_page", "cp037"), enc) diffs.append({"segment": k + 1, "name": a[0], "diffs": d["diffs"]}) - return {"records": max(len(left), len(right)), "diffs": diffs} + records = max(len(left), len(right)) + return {"records": records, "equal": records - len(diffs), "filler_differs": 0, "diffs": diffs} diff --git a/tests/tools/evidence.py b/tests/tools/evidence.py index b4f1f801f4..b2faeef01e 100644 --- a/tests/tools/evidence.py +++ b/tests/tools/evidence.py @@ -101,12 +101,13 @@ HARNESS = ("tests/tools/equivalence.py", "tests/tools/equivalence_common.py", "tests/tools/equivalence_java.py", "tests/tools/equivalence_inputs.py", "tests/tools/equivalence_cics.py", "tests/tools/equivalence_call.py", "tests/tools/equivalence_cache.py", "tests/tools/equivalence_db2.py", "tests/tools/equivalence_oracle.py", - "tests/tools/cobol_coverage.py", "tests/tools/java_target_matrix.py") # fmt: skip + "tests/tools/cobol_coverage.py", "tests/tools/java_target_matrix.py", + "tests/tools/equivalence_ims.py") # fmt: skip CRUCIBLE_HARNESS = (*HARNESS, "tests/tools/cics_crucible.py", "tests/tools/cics_crucible_compare.py") ORACLE = ("tests/equivalence/gnucobol.Dockerfile", "tests/equivalence/gnucobol-db2.Dockerfile", "tests/equivalence/odbc_cli.pin", "tests/equivalence/cics/**", "tests/equivalence/le/**", "tests/equivalence/faults/**", - "tests/equivalence/db2/**", "tests/tools/equivalence_sql.py") # fmt: skip + "tests/equivalence/db2/**", "tests/tools/equivalence_sql.py", "tests/equivalence/ims/ggdli.c") # fmt: skip GENERATOR = ("gitgalaxy/tools/cobol_to_java/**",) # #4048 Q2 (default): the Java generator, not the whole engine NOT_PORT = ("*/provenance.json", f"*/{RECORD_NAME}") EMPTY_SHA = hashlib.sha256(b"").hexdigest() @@ -200,6 +201,7 @@ class Use: db2: bool programs: bool = False port_text: Callable[[], str] = lambda: "" + ims: bool = False # #4893: a batch DL/I case (its "ims" section) @property def crucible(self) -> bool: @@ -285,6 +287,20 @@ class Component: lambda u: u.db2, "ggsql.c / ggsqlrun.c, the Db2 units of work and the SQL precompiler: Db2 cases only", ), + Component( + "harness:ims", + "harness", + ("tests/tools/equivalence_ims.py",), + lambda u: u.ims, + "the DL/I databases' DBD / PSB reading, seeds and comparison: IMS cases only", + ), + Component( + "oracle:ims", + "oracle", + ("tests/equivalence/ims/ggdli.c",), + lambda u: u.ims, + "ggdli.c, the DL/I model: linked into IMS cases only", + ), Component( "oracle:file-io", "oracle", @@ -362,7 +378,7 @@ def port_text() -> str: if p.endswith(".java") ) - u = Use(t.kind, t.db2, t.programs, functools.lru_cache(maxsize=1)(port_text)) + u = Use(t.kind, t.db2, t.programs, functools.lru_cache(maxsize=1)(port_text), t.ims) out: dict[str, str] = {} for c in COMPONENTS: if c.name in parts and (u.crucible or c.uses(u)): @@ -419,6 +435,7 @@ class Target: specs: dict[str, dict[str, Any]] = field(default_factory=dict) corpus: dict[str, str] = field(default_factory=dict) db2: bool = False + ims: bool = False # #4893: the case states IMS DL/I databases programs: bool = False # the case LINKs programs, whose Java the proof translates with det (linked_programs) @property @@ -469,7 +486,7 @@ def equivalence_target(case: str) -> Target: return Target(key=case, kind=data.get("kind", "batch"), case=case, program=data["program"].upper(), record=CASES / case / RECORD_NAME, port_dir=CASES / port_case / "port", specs=specs, corpus={"name": corpus, "ref": _corpus_refs().get(corpus, "")}, db2=bool(data.get("db2")), - programs=bool(data.get("programs"))) # fmt: skip + ims=bool(data.get("ims")), programs=bool(data.get("programs"))) # fmt: skip def crucible_target(case: str, program: str) -> Target: diff --git a/tests/tools/statement_inventory.py b/tests/tools/statement_inventory.py index a867aa3f43..7b24afa97f 100644 --- a/tests/tools/statement_inventory.py +++ b/tests/tools/statement_inventory.py @@ -61,7 +61,8 @@ "CEEDATE", "CEEISEC", "CEEQCEN", -} # tests/equivalence/le, faults/ggabend.c + "CBLTDLI", +} # tests/equivalence/le, faults/ggabend.c, ims/ggdli.c (#4893) BUCKETS = ("R", "S", "F", "L", "H") NAMES = {"R": "runtime-ready", "S": "storage", "F": "control flow", "L": "library", "H": "hole"} From 08c8f55d248ecb1a9b30eb7c65930c4a3d553083 Mon Sep 17 00:00:00 2001 From: squid-protocol Date: Fri, 16 Oct 2026 04:18:43 -0400 Subject: [PATCH 4/8] carddemo-paudbunl: file fault runs, det-sweep coverage and duration (Part of #4893) Co-Authored-By: Claude Opus 5.5 --- tests/equivalence/carddemo-paudbunl/case.json | 52 ++++++++++++++++++- .../det_sweep_coverage/carddemo-paudbunl.json | 31 +++++++++++ tests/equivalence/det_sweep_durations.json | 1 + 3 files changed, 83 insertions(+), 1 deletion(-) create mode 100644 tests/equivalence/det_sweep_coverage/carddemo-paudbunl.json diff --git a/tests/equivalence/carddemo-paudbunl/case.json b/tests/equivalence/carddemo-paudbunl/case.json index de230effb3..be70eec421 100644 --- a/tests/equivalence/carddemo-paudbunl/case.json +++ b/tests/equivalence/carddemo-paudbunl/case.json @@ -47,5 +47,55 @@ "DBPAUTP0" ] }, - "notes": "Job UNLDPADB step STEP01 (DFSRRC00 PARM='DLI,PAUDBUNL,PAUTBUNL'): IMS enters PAUDBUNL at ENTRY 'DLITCBL' with the one DB PCB of PSB PAUTBUNL, and it unloads the pending-authorization database DBPAUTP0 (HIDAM: root PAUTSUM0, child PAUTDTL1) with GN / GNP calls into OUTFIL1 (the roots) and OUTFIL2 (each child behind its root's key). The database is the corpus's own HD unload (data/EBCDIC/AWS.M2.CARDDEMO.IMSDATA.DBPAUTP0.dat: 22 roots, 202 children), each segment laid out by its copybook (CIPAUSMY / CIPAUDTY); its last root's key is EBCDIC spaces, so PA-ACCT-ID IS NUMERIC fails for it and it is skipped. The DL/I model is register family I (tests/equivalence/ims/ggdli.c, cobolrt/dli/DetDli.java), #4893. Derived from CardDemo (Apache-2.0; Copyright Amazon.com, Inc. or its affiliates): LICENSE and NOTICE here are the source's own." + "notes": "Job UNLDPADB step STEP01 (DFSRRC00 PARM='DLI,PAUDBUNL,PAUTBUNL'): IMS enters PAUDBUNL at ENTRY 'DLITCBL' with the one DB PCB of PSB PAUTBUNL, and it unloads the pending-authorization database DBPAUTP0 (HIDAM: root PAUTSUM0, child PAUTDTL1) with GN / GNP calls into OUTFIL1 (the roots) and OUTFIL2 (each child behind its root's key). The database is the corpus's own HD unload (data/EBCDIC/AWS.M2.CARDDEMO.IMSDATA.DBPAUTP0.dat: 22 roots, 202 children), each segment laid out by its copybook (CIPAUSMY / CIPAUDTY); its last root's key is EBCDIC spaces, so PA-ACCT-ID IS NUMERIC fails for it and it is skipped. The DL/I model is register family I (tests/equivalence/ims/ggdli.c, cobolrt/dli/DetDli.java), #4893. Derived from CardDemo (Apache-2.0; Copyright Amazon.com, Inc. or its affiliates): LICENSE and NOTICE here are the source's own.", + "faults": [ + { + "name": "outfil1-open", + "plan": [ + { + "dd": "OUTFIL1", + "op": "OPEN", + "nth": 1, + "status": "30" + } + ], + "why": "30: a permanent error (IBM Enterprise COBOL for z/OS Language Reference, File status key values): OPEN OUTPUT OPFILE1 fails: 'ERROR IN OPENING OPFILE1' and 9999-ABEND (RETURN-CODE 16) before any DL/I call" + }, + { + "name": "outfil2-open", + "plan": [ + { + "dd": "OUTFIL2", + "op": "OPEN", + "nth": 1, + "status": "30" + } + ], + "why": "30: a permanent error (IBM Enterprise COBOL for z/OS Language Reference, File status key values): OPEN OUTPUT OPFILE2 fails after OPFILE1 opened: 9999-ABEND" + }, + { + "name": "outfil1-close", + "plan": [ + { + "dd": "OUTFIL1", + "op": "CLOSE", + "nth": 1, + "status": "30" + } + ], + "why": "30: a permanent error (IBM Enterprise COBOL for z/OS Language Reference, File status key values): CLOSE OPFILE1 fails after the whole unload: 'ERROR IN CLOSING 1ST FILE' and the step goes on to close OPFILE2" + }, + { + "name": "outfil2-close", + "plan": [ + { + "dd": "OUTFIL2", + "op": "CLOSE", + "nth": 1, + "status": "30" + } + ], + "why": "30: a permanent error (IBM Enterprise COBOL for z/OS Language Reference, File status key values): CLOSE OPFILE2 fails: 'ERROR IN CLOSING 2ND FILE'" + } + ] } diff --git a/tests/equivalence/det_sweep_coverage/carddemo-paudbunl.json b/tests/equivalence/det_sweep_coverage/carddemo-paudbunl.json new file mode 100644 index 0000000000..6616a1f55a --- /dev/null +++ b/tests/equivalence/det_sweep_coverage/carddemo-paudbunl.json @@ -0,0 +1,31 @@ +{ + "format": "det-sweep-coverage/2", + "scenarios": 5, + "paragraphs": { + "covered": 9, + "live": 10 + }, + "branches": { + "covered": 20, + "total": 22 + }, + "inputs": { + "case": "258b5225961862f9e438aeb8faddf9d3df5b9e70940f65db3eedd59b197512cb", + "corpus": "d0c4803872ec126eb56a170212f76207beff5ab8c2b6507dd6df4a084cdeb919", + "harness": "dd5539cffd53a157381b23fc391a96cb84f323f9aa108426031875921853fd82", + "oracle": "c792e77efbb4f727f6888e4effe6fe9f51f73ae3ad458c2ebf777d2a169e2aa6", + "components": { + "harness": { + "harness:core": "6f13d22bab57c67e9caaf5d2714906e9c7c0149a83dcfd6650e2514e2c478318", + "harness:ims": "71164b208ceea480df6a1520645834ad1e7ff0a487416112cd22cec38d3fdfbe" + }, + "oracle": { + "oracle:core": "eea2a006cc58ebd1141804b10def30c657d4d2d2a3d2a19cf5d137d9dea04359", + "oracle:file-io": "e74b2733865b6c48f5ccf8d292c81c28e4827e0229e7383baeb7a3a26327f501", + "oracle:ims": "41d363a3f96d448ca01119424ec87ee1d24416f045f46af1365ad42801a6de9c", + "oracle:le": "66f2875621048177f9d8c839aa5b86b7a6c4888fcf8a837c04900fe6e6fe673b" + } + } + }, + "measured_at": "306e0f49f09139675a3f355a0e4148350609ddb8" +} diff --git a/tests/equivalence/det_sweep_durations.json b/tests/equivalence/det_sweep_durations.json index 7718f28748..d7bcd3a4fb 100644 --- a/tests/equivalence/det_sweep_durations.json +++ b/tests/equivalence/det_sweep_durations.json @@ -28,6 +28,7 @@ "carddemo-intcalc": 159, "carddemo-intcalc-generated": 16, "carddemo-menu": 20, + "carddemo-paudbunl": 23, "carddemo-posttran": 208, "carddemo-posttran-generated": 12, "carddemo-readacct": 86, From 9ce8319d373f591ffc6e6e4e80bc6da59046f168 Mon Sep 17 00:00:00 2001 From: squid-protocol Date: Fri, 16 Oct 2026 04:19:34 -0400 Subject: [PATCH 5/8] IMS DL/I: design note, ACCEPT FROM DATE test, format (Part of #4893) Co-Authored-By: Claude Opus 5.5 --- docs/language_status/det_port_design.md | 30 +++++++++++++++++++- gitgalaxy/tools/cobol_to_java/det/program.py | 7 +++-- tests/cobol_mainframe/test_det_dli.py | 29 ++++++++++++++++++- tests/equivalence/ims/fixture/DLILVL.cbl | 2 +- 4 files changed, 63 insertions(+), 5 deletions(-) diff --git a/docs/language_status/det_port_design.md b/docs/language_status/det_port_design.md index 4864ae1b42..97d31c688d 100644 --- a/docs/language_status/det_port_design.md +++ b/docs/language_status/det_port_design.md @@ -458,7 +458,9 @@ Only generator output, never a test case: The cross-check reads every unit, each paragraph's extent ending with its program. estate-crucible PAYMAIN, refused first by its COPY DATEWS collision until #4486, now translates. *Grammar gaps*: `ENTRY 'DLITCBL' USING pcb ...` (IMS DL/I batch) is read as a statement (a placeholder CALL, as SORT); as the program's first statement with no PROCEDURE DIVISION - USING it is the program's entry, its USING the program's parameters; elsewhere it translates as a hole. A reference + USING it is the program's entry, its USING the program's parameters; elsewhere it translates as a hole. Since #4893 + `ENTRY 'DLITCBL'` as the first statement is the entry even when PROCEDURE DIVISION has a USING of its own (IMS + enters a DL/I program there, with that ENTRY's list): see "IMS DL/I" below. A reference modification of an intrinsic function (`FUNCTION CURRENT-DATE (1:4)`, `FUNCTION UPPER-CASE(A) (2:3)`) is handed to the grammar as an argument list of the same length; expr reads it as the reference modification, and gen takes the substring of an alphanumeric function's text (it had dropped the modification). Newly read: CardDemo DBUNLDGS, @@ -820,6 +822,32 @@ NULL is distinct. reads to the end of the caller's record only (`Cobol.commarea`, register X10) and a det caller passes the bytes themselves (`CicsTask.link(..., area)`). +## IMS DL/I (batch DL/I calls, #4893) + +**Slice 1: CALL 'CBLTDLI' through a DB PCB, proven on a stated database.** A batch DL/I program (IMS enters its +`ENTRY 'DLITCBL' USING pcb ...`; CMPAT=NO, a DLI region) translates whole. Its CALLs run through the det runtime's +`cobolrt/dli/DetDli` (det/dli.py emits them; RETURN-CODE 0 after each, register I1), and the oracle's through +`tests/equivalence/ims/ggdli.c`, the same rules and refusals on both sides (register family I, rule family DLI). + +- **The database is stated, not connected.** A case's `"ims"` section names its DBD and PSB sources (read by the + engine's `core/ims_gen.py`) and a seed: the corpus's own HD unload, or segments the case writes + (`tests/tools/equivalence_ims.py`). Both sides start from it, and the database each leaves is compared segment by + segment, every field of the segment's layout. +- **Modelled.** GU, GHU, GN, GHN, GNP, GHNP, ISRT, REPL and DLET; unqualified SSAs and SSAs qualified by one field; + the PCB mask's feedback; position and parentage; status blank, GA, GK, GE, GB, GP, II, DJ, DA, AC, AJ, AK, AD and AM. +- **The level fixture.** `tests/equivalence/ims/fixture` (LVLDBD, LVLPSB, DLILVL, expected.txt) is a three-level + database with every modelled call and status. Its expected output was written from IBM's documentation and + committed before either runtime ran it (policy: level estates first). On its first run both runtimes printed it line + for line (51/51) and left the same database (`tests/cobol_mainframe/test_det_dli.py`, EQUIVALENCE_E2E=1). +- **Proven.** CardDemo PAUDBUNL (`carddemo-paudbunl`) unloads the corpus's own DBPAUTP0 unload (22 roots, 202 + children) through GN / GNP into two files. It is proven on 5 runs (the step and four file faults), covering 9/10 + paragraphs and 20/22 branches. The same work made ACCEPT FROM DATE / DAY / TIME translate (`Funcs.accept`): the + translator had emitted a call to a method the runtime did not have. +- **Refused (register I5).** EXEC DLI; BMP / MPP / CICS DL/I programs and the I/O PCB (IMS TM); GSAM; DL/I calls + other than the nine; command codes and boolean SSAs; AIBTDLI / CEETDLI; HDAM order; secondary indexes; logical + relationships; load mode. CardDemo's other DL/I programs stop at one of these: PAUDBLOD (CMPAT=YES, an I/O PCB), + DBUNLDGS (GSAM PCBs), and CBPAUP0C, COPAUA0C, COPAUS0C, COPAUS1C (EXEC DLI). + ## In port_runner The combined method runs in the porting loop like any other backend, and every event lands in diff --git a/gitgalaxy/tools/cobol_to_java/det/program.py b/gitgalaxy/tools/cobol_to_java/det/program.py index 77532584a5..bf83958d90 100644 --- a/gitgalaxy/tools/cobol_to_java/det/program.py +++ b/gitgalaxy/tools/cobol_to_java/det/program.py @@ -1230,8 +1230,11 @@ def callee_types(cls: str) -> list[str]: " } catch (Goback g) {", " // the program ended", " }", - *([" DetDli.leave(); // the step ended: its databases, as it left them"] - if gen.dli_pcbs is not None else []), + *( + [" DetDli.leave(); // the step ended: its databases, as it left them"] + if gen.dli_pcbs is not None + else [] + ), f" return Cobol.num({gen.ids[id(rc)]}, CS).intValue();", " }", "", diff --git a/tests/cobol_mainframe/test_det_dli.py b/tests/cobol_mainframe/test_det_dli.py index eb854c6012..c7e6046186 100644 --- a/tests/cobol_mainframe/test_det_dli.py +++ b/tests/cobol_mainframe/test_det_dli.py @@ -140,6 +140,7 @@ def test_entry_using_reads_the_dlitcbl_entry_only(): def _unload(segments: list[tuple[str, bytes, int]], counts: dict[str, int]) -> bytes: """An HD unload as CardDemo's is laid out (register I6): header, segment records, trailer with counts.""" + def rec(level: int, name: str, body: bytes, length: int) -> bytes: head = bytes(4) + bytes([level, 0x80]) + b"\x00\x23" + length.to_bytes(2, "big") + name.ljust(8).encode("cp037") r = head + bytes(21) + body + b"\x00" @@ -177,7 +178,10 @@ def test_diff_db_pairs_segments_and_names_the_ones_that_differ(): case = {"ims": {"dbd": [], "psb": ""}} ei_definitions = ei.definitions try: - ei.definitions = lambda c, corpus: ({"X": {"segments": [{"name": "R", "bytes": 2}, {"name": "C", "bytes": 1}]}}, []) + ei.definitions = lambda c, corpus: ( + {"X": {"segments": [{"name": "R", "bytes": 2}, {"name": "C", "bytes": 1}]}}, + [], + ) same = _segment("R", b"r1") + _segment("C", b"c") assert ei.diff_db(case, ROOT, "X", same, same) == {"records": 2, "equal": 2, "filler_differs": 0, "diffs": []} d = ei.diff_db(case, ROOT, "X", same, _segment("R", b"r2") + _segment("C", b"c")) @@ -331,3 +335,26 @@ def test_a_seed_out_of_sequence_is_refused_by_both_runtimes(tmp_path, seed, why) with pytest.raises(subprocess.CalledProcessError) as e: _java_side(tmp_path / "java", seed) assert why in (e.value.stderr or "") + + +@pytest.mark.skipif(_jdk() is None, reason="needs a JDK 17 (JAVA_HOME / JDK_17)") +def test_accept_from_date_day_and_time_read_the_runs_clock(tmp_path): + """ACCEPT FROM DATE / DATE YYYYMMDD / DAY / DAY YYYYDDD / TIME (PAUDBUNL's 1000-INITIALIZE): the clock's digits as + the unsigned integer item IBM names, the day of the year counted in a leap year.""" + from gitgalaxy.tools.cobol_to_java.det import program as P + + src = tmp_path / "src" + for rel, text in P.runtime_files("t", batch=False).items(): + if not rel.startswith(("cobolrt/cics/", "cobolrt/sql/")): + (src / "t" / rel).parent.mkdir(parents=True, exist_ok=True) + (src / "t" / rel).write_text(text) + forms = ["DATE", "DATE YYYYMMDD", "DAY", "DAY YYYYDDD", "TIME"] + calls = " ".join(f'System.out.println(t.cobolrt.Cobol.displayText(t.cobolrt.Funcs.accept("2024031514302512+0000", ' + f'"{f}"), java.nio.charset.StandardCharsets.ISO_8859_1));' for f in forms) # fmt: skip + (src / "Main.java").write_text(f"public class Main {{ public static void main(String[] a) {{ {calls} }} }}\n") + jdk = _jdk() + subprocess.run([str(jdk / "javac"), "-encoding", "UTF-8", "-nowarn", "-d", str(tmp_path / "classes"), # noqa: S603 + *map(str, src.rglob("*.java"))], check=True) # fmt: skip + out = subprocess.run([str(jdk / "java"), "-cp", str(tmp_path / "classes"), "Main"], capture_output=True, text=True, # noqa: S603 + check=True).stdout.split() # fmt: skip + assert out == ["240315", "20240315", "24075", "2024075", "14302512"] diff --git a/tests/equivalence/ims/fixture/DLILVL.cbl b/tests/equivalence/ims/fixture/DLILVL.cbl index c7469e85c3..9c3c72f52b 100644 --- a/tests/equivalence/ims/fixture/DLILVL.cbl +++ b/tests/equivalence/ims/fixture/DLILVL.cbl @@ -1,7 +1,7 @@ IDENTIFICATION DIVISION. PROGRAM-ID. DLILVL. * #4893 level fixture: every modelled DL/I call and status code on - * LVLDBD through PSB LVLPSB. Its expected output, expected.txt, was + * LVLDBD through PSB LVLPSB. Its expected output (expected.txt) was * written from IBM's documentation before either runtime ran it; * each step's comment cites the rule (register I1-I5). DATA DIVISION. From fbe1a66562953d95b9fab455ffbdc4c784e512f5 Mon Sep 17 00:00:00 2001 From: squid-protocol Date: Fri, 16 Oct 2026 04:21:16 -0400 Subject: [PATCH 6/8] det: Gen.dli_pcbs declared (mypy) (Part of #4893) Co-Authored-By: Claude Opus 5.5 --- gitgalaxy/tools/cobol_to_java/det/dli.py | 2 +- gitgalaxy/tools/cobol_to_java/det/gen.py | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/gitgalaxy/tools/cobol_to_java/det/dli.py b/gitgalaxy/tools/cobol_to_java/det/dli.py index 957fc0d24c..460fb2afd5 100644 --- a/gitgalaxy/tools/cobol_to_java/det/dli.py +++ b/gitgalaxy/tools/cobol_to_java/det/dli.py @@ -37,7 +37,7 @@ def call(gen: Any, s: S.Stmt, ind: str) -> list[str]: """CALL 'CBLTDLI' USING function pcb io-area [ssa-1 ... ssa-15]: DetDli.call, then RETURN-CODE 0.""" from gitgalaxy.tools.cobol_to_java.det.gen import Untranslatable - pcbs = getattr(gen, "dli_pcbs", None) + pcbs = gen.dli_pcbs if pcbs is None: raise Untranslatable(f"CALL {CALL}: a program IMS does not enter at ENTRY '{ENTRY}' (BMP, MPP or CICS) " "is not modelled") # fmt: skip diff --git a/gitgalaxy/tools/cobol_to_java/det/gen.py b/gitgalaxy/tools/cobol_to_java/det/gen.py index 1039ede864..22a98fe932 100644 --- a/gitgalaxy/tools/cobol_to_java/det/gen.py +++ b/gitgalaxy/tools/cobol_to_java/det/gen.py @@ -240,6 +240,7 @@ def __init__(self, prog: Program, structured: bool = False): self.java_root: Path | None = None # the generated project's src/main/java self.id_methods: dict = {} # entity -> its id_ method lines (det.entity) # where the program's copybooks are (a DTO field's declaration is read there) # det.cics.Cics for a CICS program self.sql: Any = None # det.sql.Sql for a program with EXEC SQL + self.dli_pcbs: list[str] | None = None # #4893: the PCBs IMS passes at ENTRY 'DLITCBL' (det/dli.py) self.clock = "clock.currentDate()" # FUNCTION CURRENT-DATE outside CICS self.uses_random = False # FUNCTION RANDOM: the program keeps a run unit's sequence (Funcs.Random) self.callees: dict[str, str] = {} # CALLed program -> the ObjectProvider field of its service From f38661fb5deb079715dddb1f73907a41de3d2118 Mon Sep 17 00:00:00 2001 From: squid-protocol Date: Fri, 16 Oct 2026 04:29:00 -0400 Subject: [PATCH 7/8] det: ACCEPT FROM DATE in cobolrt/Accept.java, so no other port moves (Part of #4893) Co-Authored-By: Claude Opus 5.5 --- docs/language_status/cobolrt_rules.json | 5 ++-- docs/language_status/det_port_design.md | 2 +- .../cobol_to_java/det/cobolrt/Accept.java | 28 +++++++++++++++++++ .../cobol_to_java/det/cobolrt/Funcs.java | 21 -------------- gitgalaxy/tools/cobol_to_java/det/gen.py | 4 +-- gitgalaxy/tools/cobol_to_java/det/program.py | 6 ++++ tests/cobol_mainframe/test_det_dli.py | 2 +- 7 files changed, 41 insertions(+), 27 deletions(-) create mode 100644 gitgalaxy/tools/cobol_to_java/det/cobolrt/Accept.java diff --git a/docs/language_status/cobolrt_rules.json b/docs/language_status/cobolrt_rules.json index 5c16582516..878d1f5e23 100644 --- a/docs/language_status/cobolrt_rules.json +++ b/docs/language_status/cobolrt_rules.json @@ -165,7 +165,8 @@ "prefix": "FUNC", "title": "intrinsic functions", "files": [ - "Funcs.java" + "Funcs.java", + "Accept.java" ], "done": true, "about": "The intrinsic functions the translator calls.", @@ -1909,7 +1910,7 @@ "family": "FUNC", "title": "ACCEPT FROM DATE / DATE YYYYMMDD / DAY / DAY YYYYDDD / TIME: the run's clock as the unsigned integer item IBM describes, moved as that item", "methods": [ - "accept" + "from" ], "ibm": { "doc": "cobol-lr", diff --git a/docs/language_status/det_port_design.md b/docs/language_status/det_port_design.md index 97d31c688d..f79604aaa3 100644 --- a/docs/language_status/det_port_design.md +++ b/docs/language_status/det_port_design.md @@ -841,7 +841,7 @@ NULL is distinct. for line (51/51) and left the same database (`tests/cobol_mainframe/test_det_dli.py`, EQUIVALENCE_E2E=1). - **Proven.** CardDemo PAUDBUNL (`carddemo-paudbunl`) unloads the corpus's own DBPAUTP0 unload (22 roots, 202 children) through GN / GNP into two files. It is proven on 5 runs (the step and four file faults), covering 9/10 - paragraphs and 20/22 branches. The same work made ACCEPT FROM DATE / DAY / TIME translate (`Funcs.accept`): the + paragraphs and 20/22 branches. The same work made ACCEPT FROM DATE / DAY / TIME translate (`cobolrt/Accept.java`): the translator had emitted a call to a method the runtime did not have. - **Refused (register I5).** EXEC DLI; BMP / MPP / CICS DL/I programs and the I/O PCB (IMS TM); GSAM; DL/I calls other than the nine; command codes and boolean SSAs; AIBTDLI / CEETDLI; HDAM order; secondary indexes; logical diff --git a/gitgalaxy/tools/cobol_to_java/det/cobolrt/Accept.java b/gitgalaxy/tools/cobol_to_java/det/cobolrt/Accept.java new file mode 100644 index 0000000000..74a0a0fb1a --- /dev/null +++ b/gitgalaxy/tools/cobol_to_java/det/cobolrt/Accept.java @@ -0,0 +1,28 @@ +package __PACKAGE__.cobolrt; + +/** ACCEPT identifier FROM the system date or time (#4893): a class of its own, so a port that never ACCEPTs names it not. */ +public final class Accept { + private Accept() { + } + + /** ACCEPT FROM DATE / DATE YYYYMMDD / DAY / DAY YYYYDDD / TIME: the run's clock -- `currentDate`, FUNCTION + * CURRENT-DATE's YYYYMMDDhhmmsshh -- as the unsigned integer item IBM describes (YYMMDD, YYYYMMDD, YYDDD, YYYYDDD, + * hhmmsshh), which the ACCEPT moves to its target as a MOVE of that item would. */ + // [rule RT-FUNC-ACCEPT-DATE] + public static Field from(String currentDate, String what) { + java.time.LocalDate d = java.time.LocalDate.of(Integer.parseInt(currentDate.substring(0, 4)), + Integer.parseInt(currentDate.substring(4, 6)), Integer.parseInt(currentDate.substring(6, 8))); + String doy = String.format(java.util.Locale.ROOT, "%03d", d.getDayOfYear()); + String digits; + switch (what) { + case "DATE": digits = currentDate.substring(2, 8); break; + case "DATE YYYYMMDD": digits = currentDate.substring(0, 8); break; + case "DAY": digits = currentDate.substring(2, 4) + doy; break; + case "DAY YYYYDDD": digits = currentDate.substring(0, 4) + doy; break; + case "TIME": digits = currentDate.substring(8, 16); break; + default: throw new UnsupportedOperationException("ACCEPT FROM " + what + " is not modelled"); + } + Storage s = Storage.of(digits.getBytes(java.nio.charset.StandardCharsets.ISO_8859_1)); + return Field.zoned(s, 0, digits.length(), 0, false, false, false); + } +} diff --git a/gitgalaxy/tools/cobol_to_java/det/cobolrt/Funcs.java b/gitgalaxy/tools/cobol_to_java/det/cobolrt/Funcs.java index 0e102ed31d..d9536b7654 100644 --- a/gitgalaxy/tools/cobol_to_java/det/cobolrt/Funcs.java +++ b/gitgalaxy/tools/cobol_to_java/det/cobolrt/Funcs.java @@ -124,27 +124,6 @@ public static String currentDate(java.time.LocalDateTime now) { + String.format(java.util.Locale.ROOT, "%02d", now.getNano() / 10_000_000) + "+0000"; } - /** ACCEPT identifier FROM DATE / DATE YYYYMMDD / DAY / DAY YYYYDDD / TIME (#4893): the run's clock -- `currentDate`, - * FUNCTION CURRENT-DATE's YYYYMMDDhhmmsshh -- as the unsigned integer item IBM describes (YYMMDD, YYYYMMDD, - * YYDDD, YYYYDDD, hhmmsshh), which the ACCEPT moves to its target as a MOVE of that item would. */ - // [rule RT-FUNC-ACCEPT-DATE] - public static Field accept(String currentDate, String from) { - java.time.LocalDate d = java.time.LocalDate.of(Integer.parseInt(currentDate.substring(0, 4)), - Integer.parseInt(currentDate.substring(4, 6)), Integer.parseInt(currentDate.substring(6, 8))); - String doy = String.format(java.util.Locale.ROOT, "%03d", d.getDayOfYear()); - String digits; - switch (from) { - case "DATE": digits = currentDate.substring(2, 8); break; - case "DATE YYYYMMDD": digits = currentDate.substring(0, 8); break; - case "DAY": digits = currentDate.substring(2, 4) + doy; break; - case "DAY YYYYDDD": digits = currentDate.substring(0, 4) + doy; break; - case "TIME": digits = currentDate.substring(8, 16); break; - default: throw new UnsupportedOperationException("ACCEPT FROM " + from + " is not modelled"); - } - Storage s = Storage.of(digits.getBytes(java.nio.charset.StandardCharsets.ISO_8859_1)); - return Field.zoned(s, 0, digits.length(), 0, false, false, false); - } - /** FUNCTION RANDOM, one run unit's sequence (oracle_assumptions.md C12). IBM documents the interface only -- * argument-1 a seed, zero or a positive integer; a first reference with no argument-1 seeds zero; a reference * with no argument-1 takes the next number of the current sequence -- not the generator. This is GnuCOBOL diff --git a/gitgalaxy/tools/cobol_to_java/det/gen.py b/gitgalaxy/tools/cobol_to_java/det/gen.py index 22a98fe932..fa16a2566b 100644 --- a/gitgalaxy/tools/cobol_to_java/det/gen.py +++ b/gitgalaxy/tools/cobol_to_java/det/gen.py @@ -1985,10 +1985,10 @@ def _statement(self, s: S.Stmt, ind: str) -> list[str]: return [c, *self.call(s, ind)] if k == "ACCEPT": frm = s.data["from"] - # #4893: the run's clock (FUNCTION CURRENT-DATE's) as the unsigned integer item IBM names (Funcs.accept) + # #4893: the run's clock (FUNCTION CURRENT-DATE's) as the unsigned integer item IBM names (Accept.from) if frm not in ("DATE", "DATE YYYYMMDD", "TIME", "DAY", "DAY YYYYDDD"): raise Untranslatable(f"ACCEPT FROM {frm}") - src = f"Funcs.accept({self.current_date_expr()}, {jstr(frm)})" + src = f"Accept.from({self.current_date_expr()}, {jstr(frm)})" return [c, f"{ind}Cobol.move({src}, {self.field_expr(s.data['target'])}, CS);"] if k == "STRING": return [c, *self.string(s, ind)] diff --git a/gitgalaxy/tools/cobol_to_java/det/program.py b/gitgalaxy/tools/cobol_to_java/det/program.py index bf83958d90..d525d830b4 100644 --- a/gitgalaxy/tools/cobol_to_java/det/program.py +++ b/gitgalaxy/tools/cobol_to_java/det/program.py @@ -1268,6 +1268,12 @@ def callee_types(cls: str) -> list[str]: java = java.replace( f"import {pkg}.cobolrt.Funcs;\n", f"import {pkg}.cobolrt.Funcs;\nimport {pkg}.cobolrt.Hfp;\n", 1 ) + if ( + "Accept.from(" in java + ): # #4893: ACCEPT FROM DATE / DAY / TIME, imported only where it is used (no other port changes) + java = java.replace( + f"import {pkg}.cobolrt.Funcs;\n", f"import {pkg}.cobolrt.Accept;\nimport {pkg}.cobolrt.Funcs;\n", 1 + ) java = drop_unused_fields(java) page = engine.page(program) if engine is not None else None # #4462: the card read in the declared code page return Result(with_trunc(java, trunc_mode(program, options, page), numproc_pfd(program, options, page)), service, diff --git a/tests/cobol_mainframe/test_det_dli.py b/tests/cobol_mainframe/test_det_dli.py index c7e6046186..41fdcf4781 100644 --- a/tests/cobol_mainframe/test_det_dli.py +++ b/tests/cobol_mainframe/test_det_dli.py @@ -349,7 +349,7 @@ def test_accept_from_date_day_and_time_read_the_runs_clock(tmp_path): (src / "t" / rel).parent.mkdir(parents=True, exist_ok=True) (src / "t" / rel).write_text(text) forms = ["DATE", "DATE YYYYMMDD", "DAY", "DAY YYYYDDD", "TIME"] - calls = " ".join(f'System.out.println(t.cobolrt.Cobol.displayText(t.cobolrt.Funcs.accept("2024031514302512+0000", ' + calls = " ".join(f'System.out.println(t.cobolrt.Cobol.displayText(t.cobolrt.Accept.from("2024031514302512+0000", ' f'"{f}"), java.nio.charset.StandardCharsets.ISO_8859_1));' for f in forms) # fmt: skip (src / "Main.java").write_text(f"public class Main {{ public static void main(String[] a) {{ {calls} }} }}\n") jdk = _jdk() From 04005e70d8f48d63acb018dec80d54736a0895d0 Mon Sep 17 00:00:00 2001 From: squid-protocol Date: Fri, 16 Oct 2026 05:08:43 -0400 Subject: [PATCH 8/8] test_det_dli: java runs with -Dfile.encoding / -Dstdout.encoding UTF-8, output decoded as UTF-8 (Part of #4893) Co-Authored-By: Claude Opus 5.5 --- tests/cobol_mainframe/test_det_dli.py | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/tests/cobol_mainframe/test_det_dli.py b/tests/cobol_mainframe/test_det_dli.py index 41fdcf4781..55217d2dc7 100644 --- a/tests/cobol_mainframe/test_det_dli.py +++ b/tests/cobol_mainframe/test_det_dli.py @@ -300,10 +300,10 @@ def _java_side(work: Path, seed: bytes = SEED) -> tuple[str, bytes]: jdk = _jdk() subprocess.run([str(jdk / "javac"), "-encoding", "UTF-8", "-nowarn", "-d", str(work / "classes"), # noqa: S603 *map(str, srcdir.rglob("*.java"))], check=True) # fmt: skip - run = subprocess.run([str(jdk / "java"), f"-Dgitgalaxy.dli.dir={work / 'dli'}", f"-Dgitgalaxy.dli.out={work / 'dliout'}", # noqa: S603 - "-cp", str(work / "classes"), "Main"], capture_output=True, text=True, encoding="latin-1", - check=True) # fmt: skip - return run.stdout, (work / "dliout" / "LVLDBD.out").read_bytes() + run = subprocess.run([str(jdk / "java"), "-Dfile.encoding=UTF-8", "-Dstdout.encoding=UTF-8", # noqa: S603 + f"-Dgitgalaxy.dli.dir={work / 'dli'}", f"-Dgitgalaxy.dli.out={work / 'dliout'}", + "-cp", str(work / "classes"), "Main"], capture_output=True, check=True) # fmt: skip + return run.stdout.decode("utf-8"), (work / "dliout" / "LVLDBD.out").read_bytes() @E2E @@ -334,7 +334,7 @@ def test_a_seed_out_of_sequence_is_refused_by_both_runtimes(tmp_path, seed, why) _cobol_side(tmp_path / "cobol", seed) with pytest.raises(subprocess.CalledProcessError) as e: _java_side(tmp_path / "java", seed) - assert why in (e.value.stderr or "") + assert why in (e.value.stderr or b"").decode("utf-8") @pytest.mark.skipif(_jdk() is None, reason="needs a JDK 17 (JAVA_HOME / JDK_17)") @@ -355,6 +355,6 @@ def test_accept_from_date_day_and_time_read_the_runs_clock(tmp_path): jdk = _jdk() subprocess.run([str(jdk / "javac"), "-encoding", "UTF-8", "-nowarn", "-d", str(tmp_path / "classes"), # noqa: S603 *map(str, src.rglob("*.java"))], check=True) # fmt: skip - out = subprocess.run([str(jdk / "java"), "-cp", str(tmp_path / "classes"), "Main"], capture_output=True, text=True, # noqa: S603 - check=True).stdout.split() # fmt: skip + out = subprocess.run([str(jdk / "java"), "-Dfile.encoding=UTF-8", "-Dstdout.encoding=UTF-8", "-cp", # noqa: S603 + str(tmp_path / "classes"), "Main"], capture_output=True, check=True).stdout.decode("utf-8").split() # fmt: skip assert out == ["240315", "20240315", "24075", "2024075", "14302512"]