>>SOURCE FORMAT IS FREE *> uuid256.cob — reference implementation of README.md (UUID256, random layout) in COBOL (GnuCOBOL 3.x, free format). *> *> cobc -x -O2 -o /tmp/uuid256-cob uuid256.cob && /tmp/uuid256-cob (self-tests + exact duplicate check over 200,000 ids) *> /tmp/uuid256-cob -n 100000 -i 3 2e5 ids with 3 planted duplicates (proves detection) *> /tmp/uuid256-cob -g 5 just print five new ids, nothing else *> *> API (paragraphs — COBOL has no functions with return values, so each works on WORKING-STORAGE fields): *> GENERATE-ID §5.1 ID-BYTES := 32 bytes from getentropy(2) (called straight into libc: the OS CSPRNG) with §4 applied *> SET-VER-VAR §4 COBOL has no bit operators, so: byte13 := MOD(byte13,16) + 64 byte17 := MOD(byte17,64) + 128 *> IS-STRICT §6 STRICT-FLAG := (byte13 / 16 = 4) AND (byte17 / 64 = 2) (integer division) *> TO-CANONICAL §3.1 TXT := 16-8-8-8-24 lowercase hex of ID-BYTES *> PARSE-ID §6 PARSE-IN/PARSE-LEN/PARSE-STRICT → PARSE-OUT, PARSE-ERR (0 ok · 1 length · 2 hyphen · 3 char · 4 version) *> Bulk check: one getentropy per id, §4 applied, then a table SORT on the 32-byte ids (indices carried alongside), *> adjacent-compare → exact. IDENTIFICATION DIVISION. PROGRAM-ID. UUID256. DATA DIVISION. WORKING-STORAGE SECTION. 01 HEX-TABLE PIC X(16) VALUE "0123456789abcdef". 01 LEN32 PIC S9(9) COMP-5 VALUE 32. 01 ID-BYTES PIC X(32). 01 ID-BYTE-TBL REDEFINES ID-BYTES. 05 ID-BYTE PIC X OCCURS 32. 01 TXT PIC X(68). 01 V PIC 9(3). 01 HI PIC 9(3). 01 LO PIC 9(3). 01 I PIC 9(9) COMP. 01 P PIC 9(9) COMP. 01 CI PIC 9(9) COMP. *> TO-CANONICAL's own counters (COBOL variables are global: 01 CP PIC 9(9) COMP. *> reusing I inside a PERFORM VARYING I loop would reset it) 01 STRICT-FLAG PIC X VALUE "N". *> ---- parse ---- 01 PARSE-IN PIC X(68). 01 PARSE-LEN PIC 9(3). 01 PARSE-STRICT PIC X VALUE "Y". 01 PARSE-OUT PIC X(32). 01 PARSE-OUT-TBL REDEFINES PARSE-OUT. 05 PARSE-BYTE PIC X OCCURS 32. 01 PARSE-ERR PIC 9. 01 PARSE-LOW PIC X(68). 01 PARSE-HEX PIC X(64). 01 PARSE-HY PIC X. 01 PARSE-C PIC X. 01 PARSE-V PIC S9(3). 01 PARSE-NIB PIC 9. 01 PARSE-CUR PIC 9(3). 01 PARSE-BI PIC 99. 01 PARSE-K PIC 99. 01 SAVE-ID PIC X(32). *> ---- self-test ---- 01 VEC-IN-1 PIC X(64) VALUE "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f". 01 VEC-OUT-1 PIC X(68) VALUE "0001020304050607-08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1f". 01 VEC-IN-2 PIC X(64) VALUE "fffefdfcfbfaf9f8f7f6f5f4f3f2f1f0efeeedecebeae9e8e7e6e5e4e3e2e1e0". 01 VEC-OUT-2 PIC X(68) VALUE "fffefdfcfbfaf9f8-f7f6f5f4-43f2f1f0-afeeedec-ebeae9e8e7e6e5e4e3e2e1e0". 01 VEC-IN PIC X(64). 01 VEC-OUT PIC X(68). 01 VEC-N PIC 9. 01 OK-FLAG PIC X. 01 FAILS PIC 9(3) VALUE 0. 01 E1 PIC 9. 01 E2 PIC 9. 01 E3 PIC 9. 01 E4 PIC 9. 01 E5 PIC 9. 01 NIL-TXT PIC X(68). 01 ALL-F PIC X(68). *> ---- CLI / bulk ---- 01 ARGC PIC 9(3). 01 ARG-1 PIC X(200). 01 ARG-2 PIC X(200). 01 ARG-3 PIC X(200). 01 ARG-4 PIC X(200). 01 ARG-5 PIC X(200). 01 MODE-G PIC X VALUE "N". 01 COUNT-G PIC 9(9) VALUE 1. 01 N-IDS PIC 9(9) VALUE 200000. 01 PLANTED PIC 9(9) VALUE 0. 01 N-MAX PIC 9(9) VALUE 1000000. 01 N-CAP PIC 9(9) COMP. 01 REC-TABLE. 05 REC OCCURS 1 TO 1000000 DEPENDING ON N-CAP. 10 REC-ID PIC X(32). 10 REC-IDX PIC 9(9) COMP. 01 KK PIC 9(9). 01 SRC PIC 9(9). 01 DST PIC 9(9). 01 HALF PIC 9(9). 01 BAD PIC 9(9) VALUE 0. 01 NDUPS PIC 9(9) VALUE 0. 01 RT-OK PIC 9(9) VALUE 0. 01 STEP-N PIC 9(9). 01 IDX-A PIC 9(9). 01 IDX-B PIC 9(9). 01 T0 PIC 9(7)V99. 01 T1 PIC 9(7)V99. 01 T2 PIC 9(7)V99. 01 DT-A PIC 9(5)V9. 01 DT-B PIC 9(5)V9. 01 NOW-STR PIC X(21). 01 ED-9 PIC ZZZ,ZZZ,ZZ9. 01 ED-9B PIC ZZZ,ZZZ,ZZ9. 01 ED-T PIC ZZZZ9.9. 01 LOG2P PIC ----9.9. 01 LOG10P PIC ----9.9. 01 LOG2P-N PIC S9(4)V9. 01 VERDICT PIC X(14). PROCEDURE DIVISION. MAIN. *> one ACCEPT per argument (ARGUMENT-VALUE keeps each argv element intact — spaces inside an argument survive; *> only trailing spaces are lost to the fixed-width field, an inherent COBOL limitation) ACCEPT ARGC FROM ARGUMENT-NUMBER IF ARGC >= 1 DISPLAY 1 UPON ARGUMENT-NUMBER ACCEPT ARG-1 FROM ARGUMENT-VALUE END-IF IF ARGC >= 2 DISPLAY 2 UPON ARGUMENT-NUMBER ACCEPT ARG-2 FROM ARGUMENT-VALUE END-IF IF ARGC >= 3 DISPLAY 3 UPON ARGUMENT-NUMBER ACCEPT ARG-3 FROM ARGUMENT-VALUE END-IF IF ARGC >= 4 DISPLAY 4 UPON ARGUMENT-NUMBER ACCEPT ARG-4 FROM ARGUMENT-VALUE END-IF IF ARGC >= 5 DISPLAY 5 UPON ARGUMENT-NUMBER ACCEPT ARG-5 FROM ARGUMENT-VALUE END-IF IF ARG-1 = "-p" OR ARG-1 = "-P" *> parse mode: -p strict, -P lenient MOVE ARG-2 TO PARSE-IN COMPUTE PARSE-LEN = FUNCTION LENGTH(FUNCTION TRIM(ARG-2 TRAILING)) IF ARG-1 = "-p" MOVE "Y" TO PARSE-STRICT ELSE MOVE "N" TO PARSE-STRICT END-IF PERFORM PARSE-ID IF PARSE-ERR = 0 MOVE PARSE-OUT TO ID-BYTES PERFORM TO-CANONICAL DISPLAY "ok " TXT(1:16) TXT(18:8) TXT(27:8) TXT(36:8) TXT(45:24) STOP RUN END-IF EVALUATE PARSE-ERR WHEN 1 DISPLAY "error length" WHEN 2 DISPLAY "error hyphen" WHEN 3 DISPLAY "error char" WHEN OTHER DISPLAY "error version" END-EVALUATE MOVE 1 TO RETURN-CODE STOP RUN END-IF IF ARG-1 = "-g" MOVE 1 TO COUNT-G IF ARG-2 NOT = SPACES AND FUNCTION TEST-NUMVAL(ARG-2) = 0 COMPUTE COUNT-G = FUNCTION NUMVAL(ARG-2) IF ARG-2(1:1) = "-" MOVE 1 TO COUNT-G END-IF *> -g N: exactly N (0 allowed); junk → 1 END-IF PERFORM COUNT-G TIMES PERFORM GENERATE-ID PERFORM TO-CANONICAL DISPLAY TXT END-PERFORM STOP RUN END-IF PERFORM PARSE-ARGS IF N-IDS < 2 OR N-IDS > N-MAX OR PLANTED > N-IDS / 2 DISPLAY "-n must be 2..1000000 and -i at most n/2" MOVE 2 TO RETURN-CODE STOP RUN END-IF DISPLAY "UUID256 reference implementation (COBOL) — README.md (256-bit random, 16-8-8-8-24 text)" DISPLAY " " DISPLAY "Self-tests:" PERFORM SELF-TEST IF FAILS > 0 DISPLAY " self-test FAILED — aborting" MOVE 1 TO RETURN-CODE STOP RUN END-IF MOVE N-IDS TO ED-9 MOVE PLANTED TO ED-9B DISPLAY " " DISPLAY "Bulk exact duplicate check: n=" FUNCTION TRIM(ED-9) " ids, planted duplicates=" FUNCTION TRIM(ED-9B) MOVE N-IDS TO N-CAP PERFORM GET-TIME MOVE T0 TO T1 PERFORM VARYING I FROM 1 BY 1 UNTIL I > N-IDS PERFORM GENERATE-ID *> §5.1 per id MOVE ID-BYTES TO REC-ID(I) COMPUTE REC-IDX(I) = I - 1 END-PERFORM PERFORM GET-TIME MOVE T0 TO T1 COMPUTE HALF = N-IDS / 2 PERFORM VARYING KK FROM 0 BY 1 UNTIL KK >= PLANTED *> id[dst] := id[src] COMPUTE SRC = KK * (HALF / PLANTED) *> stride: distinct pairs for every k < planted <= n/2 COMPUTE DST = N-IDS - 1 - SRC MOVE REC-ID(SRC + 1) TO REC-ID(DST + 1) MOVE DST TO ED-9 MOVE SRC TO ED-9B DISPLAY " planted: id[" FUNCTION TRIM(ED-9) "] := id[" FUNCTION TRIM(ED-9B) "]" END-PERFORM MOVE 0 TO BAD PERFORM VARYING I FROM 1 BY 1 UNTIL I > N-IDS MOVE REC-ID(I) TO ID-BYTES PERFORM IS-STRICT IF STRICT-FLAG = "N" ADD 1 TO BAD END-IF END-PERFORM *> sampled text round-trips (before the sort reorders the table) COMPUTE STEP-N = N-IDS / 1000 IF STEP-N < 1 MOVE 1 TO STEP-N END-IF MOVE 0 TO RT-OK PERFORM VARYING I FROM 1 BY STEP-N UNTIL I > N-IDS MOVE REC-ID(I) TO ID-BYTES PERFORM TO-CANONICAL MOVE TXT TO PARSE-IN MOVE 68 TO PARSE-LEN MOVE "Y" TO PARSE-STRICT PERFORM PARSE-ID IF PARSE-ERR = 0 AND PARSE-OUT = ID-BYTES ADD 1 TO RT-OK END-IF END-PERFORM *> exact duplicate detection: sort by id, compare neighbours SORT REC ON ASCENDING KEY REC-ID MOVE 0 TO NDUPS PERFORM VARYING I FROM 2 BY 1 UNTIL I > N-IDS IF REC-ID(I) = REC-ID(I - 1) ADD 1 TO NDUPS IF REC-IDX(I - 1) < REC-IDX(I) MOVE REC-IDX(I - 1) TO IDX-A MOVE REC-IDX(I) TO IDX-B ELSE MOVE REC-IDX(I) TO IDX-A MOVE REC-IDX(I - 1) TO IDX-B END-IF MOVE REC-ID(I) TO ID-BYTES PERFORM TO-CANONICAL MOVE IDX-A TO ED-9 MOVE IDX-B TO ED-9B DISPLAY " DUPLICATE id[" FUNCTION TRIM(ED-9) "] == id[" FUNCTION TRIM(ED-9B) "] " TXT END-IF END-PERFORM PERFORM GET-TIME MOVE T0 TO T2 DISPLAY " " DISPLAY "==== RESULT ====" MOVE N-IDS TO ED-9 COMPUTE DT-A = T1 - T0 + (T2 - T1) DISPLAY "ids generated: " FUNCTION TRIM(ED-9) " (getentropy per id + §4; SORT-based dedup)" MOVE BAD TO ED-9 DISPLAY "version/variant violations: " FUNCTION TRIM(ED-9) MOVE RT-OK TO ED-9 DISPLAY "text round-trips (sampled): " FUNCTION TRIM(ED-9) " ok" MOVE NDUPS TO ED-9 IF PLANTED > 0 IF NDUPS = PLANTED MOVE "all detected" TO VERDICT ELSE MOVE "COUNT MISMATCH" TO VERDICT END-IF MOVE PLANTED TO ED-9B DISPLAY "FULL 256-bit DUPLICATES: " FUNCTION TRIM(ED-9) " (planted: " FUNCTION TRIM(ED-9B) " — " FUNCTION TRIM(VERDICT) ")" ELSE DISPLAY "FULL 256-bit DUPLICATES: " FUNCTION TRIM(ED-9) END-IF MOVE N-IDS TO ED-9 IF NDUPS = 0 DISPLAY " → no duplicates among " FUNCTION TRIM(ED-9) " ids" END-IF COMPUTE LOG2P-N = 2 * FUNCTION LOG(N-IDS) / FUNCTION LOG(2) - 251 MOVE LOG2P-N TO LOG2P COMPUTE LOG2P-N = LOG2P-N * 0.30103 MOVE LOG2P-N TO LOG10P DISPLAY "expected P(any collision) §5.3: n²/2²⁵¹ ≈ 2^" FUNCTION TRIM(LOG2P) " ≈ 10^" FUNCTION TRIM(LOG10P) IF NDUPS NOT = PLANTED MOVE 1 TO RETURN-CODE END-IF STOP RUN. PARSE-ARGS. *> every argument must be a "-n " or "-i " pair; anything else → usage IF ARGC > 4 OR FUNCTION MOD(ARGC, 2) = 1 PERFORM USAGE-EXIT END-IF IF ARGC >= 2 PERFORM PARSE-PAIR-1 END-IF IF ARGC >= 4 PERFORM PARSE-PAIR-2 END-IF. PARSE-PAIR-1. IF FUNCTION TEST-NUMVAL(ARG-2) NOT = 0 OR ARG-2(1:1) = "-" OR ARG-2 = SPACES PERFORM USAGE-EXIT END-IF EVALUATE ARG-1 WHEN "-n" COMPUTE N-IDS = FUNCTION NUMVAL(ARG-2) WHEN "-i" COMPUTE PLANTED = FUNCTION NUMVAL(ARG-2) WHEN OTHER PERFORM USAGE-EXIT END-EVALUATE. PARSE-PAIR-2. IF FUNCTION TEST-NUMVAL(ARG-4) NOT = 0 OR ARG-4(1:1) = "-" OR ARG-4 = SPACES PERFORM USAGE-EXIT END-IF EVALUATE ARG-3 WHEN "-n" COMPUTE N-IDS = FUNCTION NUMVAL(ARG-4) WHEN "-i" COMPUTE PLANTED = FUNCTION NUMVAL(ARG-4) WHEN OTHER PERFORM USAGE-EXIT END-EVALUATE. USAGE-EXIT. DISPLAY "usage: uuid256-cob [-g [count]] [-n count] [-i planted_dups] | -p|-P " MOVE 2 TO RETURN-CODE STOP RUN. *> ---- §5.1: 32 bytes from the OS CSPRNG, then §4 ---------------------------------------- GENERATE-ID. CALL "getentropy" USING BY REFERENCE ID-BYTES BY VALUE LEN32 IF RETURN-CODE NOT = 0 DISPLAY "uuid256: getentropy failed" MOVE 1 TO RETURN-CODE STOP RUN END-IF PERFORM SET-VER-VAR. *> ---- §4: version nibble (byte 13, 1-based) and variant bits (byte 17) — arithmetic, no bit ops ---- SET-VER-VAR. COMPUTE V = FUNCTION ORD(ID-BYTE(13)) - 1 COMPUTE V = FUNCTION MOD(V, 16) + 64 *> (b & 0x0F) | 0x40 → hex digit 24 = '4' MOVE FUNCTION CHAR(V + 1) TO ID-BYTE(13) COMPUTE V = FUNCTION ORD(ID-BYTE(17)) - 1 COMPUTE V = FUNCTION MOD(V, 64) + 128 *> (b & 0x3F) | 0x80 → hex digit 32 in [89ab] MOVE FUNCTION CHAR(V + 1) TO ID-BYTE(17). *> ---- §6: ver == 4 && var == 10 ------------------------------------------------------------- IS-STRICT. MOVE "N" TO STRICT-FLAG COMPUTE V = FUNCTION ORD(ID-BYTE(13)) - 1 DIVIDE V BY 16 GIVING HI REMAINDER LO IF HI = 4 COMPUTE V = FUNCTION ORD(ID-BYTE(17)) - 1 DIVIDE V BY 64 GIVING HI REMAINDER LO IF HI = 2 MOVE "Y" TO STRICT-FLAG END-IF END-IF. *> ---- §3.1: canonical text 16-8-8-8-24 ------------------------------------------------------- TO-CANONICAL. MOVE SPACES TO TXT MOVE 1 TO CP PERFORM VARYING CI FROM 1 BY 1 UNTIL CI > 32 COMPUTE V = FUNCTION ORD(ID-BYTE(CI)) - 1 DIVIDE V BY 16 GIVING HI REMAINDER LO MOVE HEX-TABLE(HI + 1:1) TO TXT(CP:1) MOVE HEX-TABLE(LO + 1:1) TO TXT(CP + 1:1) ADD 2 TO CP IF CI = 8 OR CI = 12 OR CI = 16 OR CI = 20 *> hyphen after hex digits 16, 24, 32, 40 MOVE "-" TO TXT(CP:1) ADD 1 TO CP END-IF END-PERFORM. *> ---- §6: parse PARSE-IN (PARSE-LEN chars, canonical 68 or compact 64, any case) → PARSE-OUT / PARSE-ERR ---- PARSE-ID. MOVE 0 TO PARSE-ERR MOVE LOW-VALUES TO PARSE-OUT MOVE FUNCTION LOWER-CASE(PARSE-IN) TO PARSE-LOW IF PARSE-LEN = 68 IF PARSE-LOW(17:1) NOT = "-" OR PARSE-LOW(26:1) NOT = "-" OR PARSE-LOW(35:1) NOT = "-" OR PARSE-LOW(44:1) NOT = "-" MOVE 2 TO PARSE-ERR END-IF MOVE "Y" TO PARSE-HY ELSE IF PARSE-LEN = 64 MOVE "N" TO PARSE-HY ELSE MOVE 1 TO PARSE-ERR END-IF END-IF IF PARSE-ERR = 0 MOVE 0 TO PARSE-NIB PARSE-CUR MOVE 1 TO PARSE-BI PERFORM VARYING P FROM 1 BY 1 UNTIL P > PARSE-LEN OR PARSE-ERR NOT = 0 IF NOT (PARSE-HY = "Y" AND (P = 17 OR P = 26 OR P = 35 OR P = 44)) MOVE PARSE-LOW(P:1) TO PARSE-C EVALUATE TRUE WHEN PARSE-C >= "0" AND PARSE-C <= "9" COMPUTE PARSE-V = FUNCTION ORD(PARSE-C) - 49 WHEN PARSE-C >= "a" AND PARSE-C <= "f" COMPUTE PARSE-V = FUNCTION ORD(PARSE-C) - 98 + 10 WHEN OTHER MOVE 3 TO PARSE-ERR END-EVALUATE IF PARSE-ERR = 0 COMPUTE PARSE-CUR = PARSE-CUR * 16 + PARSE-V ADD 1 TO PARSE-NIB IF PARSE-NIB = 2 MOVE FUNCTION CHAR(PARSE-CUR + 1) TO PARSE-BYTE(PARSE-BI) ADD 1 TO PARSE-BI MOVE 0 TO PARSE-NIB PARSE-CUR END-IF END-IF END-IF END-PERFORM END-IF IF PARSE-ERR = 0 AND PARSE-STRICT = "Y" MOVE ID-BYTES TO SAVE-ID MOVE PARSE-OUT TO ID-BYTES PERFORM IS-STRICT MOVE SAVE-ID TO ID-BYTES IF STRICT-FLAG = "N" MOVE 4 TO PARSE-ERR END-IF END-IF. *> ---- self-tests: spec §11 vectors, §3.2/§6 parser rules, live generation ------------------ SELF-TEST. PERFORM VARYING VEC-N FROM 1 BY 1 UNTIL VEC-N > 2 IF VEC-N = 1 MOVE VEC-IN-1 TO VEC-IN MOVE VEC-OUT-1 TO VEC-OUT ELSE MOVE VEC-IN-2 TO VEC-IN MOVE VEC-OUT-2 TO VEC-OUT END-IF MOVE "Y" TO OK-FLAG MOVE VEC-IN TO PARSE-IN MOVE 64 TO PARSE-LEN MOVE "N" TO PARSE-STRICT PERFORM PARSE-ID *> raw compact, lenient IF PARSE-ERR NOT = 0 MOVE "N" TO OK-FLAG END-IF MOVE PARSE-OUT TO ID-BYTES PERFORM SET-VER-VAR PERFORM TO-CANONICAL IF TXT NOT = VEC-OUT MOVE "N" TO OK-FLAG END-IF PERFORM IS-STRICT IF STRICT-FLAG = "N" MOVE "N" TO OK-FLAG END-IF MOVE TXT TO PARSE-IN MOVE 68 TO PARSE-LEN MOVE "Y" TO PARSE-STRICT PERFORM PARSE-ID *> canonical strict → same bytes IF PARSE-ERR NOT = 0 OR PARSE-OUT NOT = ID-BYTES MOVE "N" TO OK-FLAG END-IF MOVE FUNCTION UPPER-CASE(TXT) TO PARSE-IN PERFORM PARSE-ID *> uppercase accepted IF PARSE-ERR NOT = 0 OR PARSE-OUT NOT = ID-BYTES MOVE "N" TO OK-FLAG END-IF MOVE VEC-IN TO PARSE-IN MOVE 64 TO PARSE-LEN MOVE "Y" TO PARSE-STRICT PERFORM PARSE-ID *> raw compact, strict → version error IF PARSE-ERR NOT = 4 MOVE "N" TO OK-FLAG END-IF IF OK-FLAG = "Y" DISPLAY " spec §11 vector " VEC-N ": PASS " TXT ELSE DISPLAY " spec §11 vector " VEC-N ": FAIL " TXT ADD 1 TO FAILS END-IF END-PERFORM MOVE "0001020304050607_08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1f" TO PARSE-IN MOVE 68 TO PARSE-LEN MOVE "Y" TO PARSE-STRICT PERFORM PARSE-ID MOVE PARSE-ERR TO E1 MOVE "0001020304050607-08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1" TO PARSE-IN MOVE 67 TO PARSE-LEN PERFORM PARSE-ID MOVE PARSE-ERR TO E2 MOVE "0001020304050607-08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1g" TO PARSE-IN MOVE 68 TO PARSE-LEN PERFORM PARSE-ID MOVE PARSE-ERR TO E3 MOVE LOW-VALUES TO ID-BYTES PERFORM TO-CANONICAL MOVE TXT TO NIL-TXT MOVE NIL-TXT TO PARSE-IN MOVE 68 TO PARSE-LEN MOVE "Y" TO PARSE-STRICT PERFORM PARSE-ID MOVE PARSE-ERR TO E4 MOVE "N" TO PARSE-STRICT PERFORM PARSE-ID MOVE PARSE-ERR TO E5 MOVE ALL X"FF" TO ID-BYTES PERFORM TO-CANONICAL MOVE "ffffffffffffffff-ffffffff-ffffffff-ffffffff-ffffffffffffffffffffffff" TO ALL-F IF E1 = 2 AND E2 = 1 AND E3 = 3 AND E4 = 4 AND E5 = 0 AND PARSE-OUT = ALL LOW-VALUES AND TXT = ALL-F DISPLAY " parser rules (§3.2/§6): PASS" ELSE DISPLAY " parser rules (§3.2/§6): FAIL" ADD 1 TO FAILS END-IF PERFORM 3 TIMES PERFORM GENERATE-ID PERFORM TO-CANONICAL MOVE TXT TO PARSE-IN MOVE 68 TO PARSE-LEN MOVE "Y" TO PARSE-STRICT PERFORM PARSE-ID PERFORM IS-STRICT *> string offsets (1-based): hex digit 24 → char 27 (after 2 hyphens), hex digit 32 → char 36 (after 3) IF STRICT-FLAG = "Y" AND TXT(27:1) = "4" AND (TXT(36:1) = "8" OR TXT(36:1) = "9" OR TXT(36:1) = "a" OR TXT(36:1) = "b") AND PARSE-ERR = 0 AND PARSE-OUT = ID-BYTES DISPLAY " GENERATE-ID: " TXT " ok" ELSE DISPLAY " GENERATE-ID: " TXT " BAD" ADD 1 TO FAILS END-IF END-PERFORM. GET-TIME. MOVE FUNCTION CURRENT-DATE TO NOW-STR COMPUTE T0 = FUNCTION NUMVAL(NOW-STR(9:2)) * 3600 + FUNCTION NUMVAL(NOW-STR(11:2)) * 60 + FUNCTION NUMVAL(NOW-STR(13:2)) + FUNCTION NUMVAL(NOW-STR(15:2)) / 100.