(**************************************************************************)
(*                                                                        *)
(*  Encryption library                                                    *)
(*  Copyright (C) 2018-2025   Peter Moylan                                *)
(*                                                                        *)
(*  This program is free software: you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 3 of the License, or     *)
(*  (at your option) any later version.                                   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful,       *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU General Public License for more details.                          *)
(*                                                                        *)
(*  You should have received a copy of the GNU General Public License     *)
(*  along with this program.  If not, see <http://www.gnu.org/licenses/>. *)
(*                                                                        *)
(*  To contact author:   http://www.pmoylan.org   peter@pmoylan.org       *)
(*                                                                        *)
(**************************************************************************)


<* WOFF316+ *>

IMPLEMENTATION MODULE DES;

        (****************************************************************)
        (*                                                              *)
        (*               DES: Data encryption standard                  *)
        (*                                                              *)
        (*                 as specified in FIPS.46-3                    *)
        (*                                                              *)
        (*  Programmer:         P. Moylan                               *)
        (*  Started:            23 April 2018                           *)
        (*  Last edited:        3 November 2025                         *)
        (*  Status:                                                     *)
        (*      DES and DES3 pass the tests I have given it so far.     *)
        (*              CBC mode also passes the tests.                 *)
        (*                                                              *)
        (*  After failing to get an earlier version of this software    *)
        (*  working, I have gone back to first principles and           *)
        (*  implemented the algorithm at bit level as described in      *)
        (*  the standard.  This means a slight loss of speed, but for   *)
        (*  now I accept that for the sake of correctness.              *)
        (*                                                              *)
        (*  The DES and 3DES encryptions are defined in FIPS.46-3       *)
        (*                                                              *)
        (*  Overview: DES is a block code with block size = 8 bytes     *)
        (*  and key size = 8 bytes.  (But internally the key is         *)
        (*  expanded to a longer key schedule.)                         *)
        (*                                                              *)
        (*  Comment: the standard describes all operations in bigendian *)
        (*  notation, but we are executing the code on a little-endian  *)
        (*  machine.  Mostly this does not matter, but we have to take  *)
        (*  care in two ways:                                           *)
        (*    - conversion between words and byte stream;               *)
        (*    - interpreting the bit numbers in the tables in the       *)
        (*      standard.                                               *)
        (*                                                              *)
        (****************************************************************)


FROM SYSTEM IMPORT LOC, CARD8, CARD32, ADR;

FROM LowLevel IMPORT
    (* proc *)  BlockFill, Copy, IAND, IANDB, IXOR, IXORB, LS, RS;

FROM STextIO IMPORT
    (* proc *)  WriteChar, WriteString, WriteLn;

FROM HexData IMPORT             (* FOR TESTING *)
    (* proc *)  DumpWord;

FROM Storage IMPORT
    (* proc *)  ALLOCATE, DEALLOCATE;

(************************************************************************)

TYPE
    EightByte = ARRAY [0..7] OF CARD8;

    (* For DES, the key schedule is 16 longwords of 64 bits, but it is  *)
    (* more convenient to implement this as an array of 32 words of     *)
    (* 32 bits each.  For DES3 the key schedule is three times the      *)
    (* size.  It simplifies things if we just allocate the longer space *)
    (* even for DES, and accept the space overhead of the unused part.  *)

    DES3KeySchedule = ARRAY [0..95] OF CARD32;

    (* The fields in a session context are:                             *)
    (*      CBC         FALSE for ECB mode, TRUE for CBC mode           *)
    (*      decrypt     FALSE for encryption, TRUE for decryption       *)
    (*      longkey     TRUE iff we are doing DES3 rather than DES      *)
    (*      fullpadding affects how we pad the result at the end        *)
    (*      deferred    TRUE iff the results in outbuff have not yet    *)
    (*                    been sent to the caller                       *)
    (*      inbuff      input bytes read but not yet processed          *)
    (*      outbuff     the last result block                           *)
    (*      lastciphertext  a copy of the last output block during      *)
    (*                    encryption, or the last input block during    *)
    (*                    decryption. Used only in CBC mode.            *)
    (*      incount     the number of bytes in inbuff                   *)
    (*      KS          the key schedule                                *)
    (*                                                                  *)
    (* The function of inbuff is to hold input bytes in the case where  *)
    (* we don't yet have 8 bytes, i.e. we're waiting for another call   *)
    (* to DESencrypt to supply enough data to fill out the block.       *)
    (*                                                                  *)
    (* The function of outbuff is to hold results that have not yet     *)
    (* been returned to the caller.  For decryption, we need to delay   *)
    (* the results by one block, because we will have to strip padding  *)
    (* from the last block, and we won't know whether the current block *)
    (* is the last block until DESfinal is called.  For encryption, no  *)
    (* delay is necessary, but we store the result in outbuff (as well  *)
    (* as returning it to the caller) anyway, for consistency, and in   *)
    (* case we later decide to implement chaining.                      *)

    DEScontext = POINTER TO
                    RECORD
                        CBC: BOOLEAN;
                        decrypt: BOOLEAN;
                        longkey: BOOLEAN;
                        fullpadding: BOOLEAN;
                        deferred: BOOLEAN;
                        inbuff: EightByte;
                        outbuff: EightByte;
                        lastciphertext: EightByte;
                        incount: [0..8];
                        KS: DES3KeySchedule;
                    END (*RECORD*);

    (* A type used in converting between words and a byte stream. *)

    BigEndian = RECORD
                    CASE :BOOLEAN OF
                        FALSE:  word: CARD32;
                        |
                        TRUE:   byte: ARRAY [0..3] OF CARD8;
                    END (*CASE*);
                END (*RECORD*);

    (* Bit permutation maps. *)

    PermMap = ARRAY [0..63] OF CARD8;
    PermMap32 = ARRAY [0..31] OF CARD8;

(************************************************************************)
(*                           BIT PERMUTATIONS                           *)
(*                                                                      *)
(* The standard describes these as permutations on a 64-bit block,      *)
(* with the leftmost bit called bit 1.  We implement that block as a    *)
(* left half X and a right half Y.                                      *)
(************************************************************************)

PROCEDURE Permute (VAR (*INOUT*) X, Y: CARD32;  map: PermMap);

    (* Permutes bits in (X,Y) according to the given map.   *)

    CONST topbit = 80000000H;

    VAR X1, Y1: CARD32;

    (********************************************************************)

    PROCEDURE LeftShift;

        (* Logical left shift of (X1,Y1).  *)

        VAR carry: BOOLEAN;

        BEGIN
            carry := IAND (Y1, topbit) <> 0;
            Y1 := LS (Y1, 1);
            X1 := LS (X1, 1);
            IF carry THEN INC(X1) END (*IF*);
        END LeftShift;

    (********************************************************************)

    PROCEDURE PickBit (N: CARD8): BOOLEAN;

        (* Picks bit N of (X,Y), as defined in the big-endian       *)
        (* numbering in the standard, and returns TRUE iff it is 1. *)
        (* The nonexistent bit 0 is always interpreted as 0.        *)

        VAR mask: CARD32;

        BEGIN
            IF N = 0 THEN
                RETURN FALSE;
            ELSIF (N = 1) OR (N = 33) THEN
                mask := topbit;
            ELSIF N > 32 THEN
                mask := RS(topbit, N-33);
            ELSE
                mask := RS(topbit, N-1);
            END (*IF*);

            IF N > 32 THEN
                RETURN IAND (Y, mask) <> 0;
            ELSE
                RETURN IAND (X, mask) <> 0;
            END (*IF*);
        END PickBit;

    (********************************************************************)

    VAR j: CARD8;

    BEGIN
        X1 := 0;  Y1 := 0;      (* redundant, but suppresses a compiler warning *)
        FOR j := 0 TO 63 DO
            LeftShift;
            IF PickBit (map[j]) THEN INC (Y1) END (*IF*);
        END (*FOR*);
        X := X1;  Y := Y1;
    END Permute;

(************************************************************************)

PROCEDURE Permute32 (VAR (*INOUT*) X: CARD32;  map: PermMap32);

    (* Similar to Permute, but works on a single 32-bit variable.   *)

    CONST topbit = 80000000H;

    VAR result: CARD32;

    (********************************************************************)

    PROCEDURE PickBit (N: CARD8): BOOLEAN;

        (* Picks bit N of X, as defined in the big-endian           *)
        (* numbering in the standard, and returns TRUE iff it is 1. *)
        (* The nonexistent bit 0 is always interpreted as 0.        *)

        VAR mask: CARD32;

        BEGIN
            IF N = 0 THEN
                RETURN FALSE;
            ELSIF N = 1 THEN
                mask := topbit;
            ELSE
                mask := RS(topbit, N-1);
            END (*IF*);

            RETURN IAND (X, mask) <> 0;
        END PickBit;

    (********************************************************************)

    VAR j: CARD8;

    BEGIN
        result := 0;      (* redundant, but suppresses a compiler warning *)
        FOR j := 0 TO 31 DO
            result := LS (result, 1);
            IF PickBit (map[j]) THEN INC (result) END (*IF*);
        END (*FOR*);
        X := result;
    END Permute32;

(************************************************************************)
(*                      A FEW PRIMITIVE OPERATIONS                      *)
(************************************************************************)

PROCEDURE ClearBlock (VAR (*OUT*) v: ARRAY OF LOC;  n: CARDINAL);

    (* Sets a block of n bytes to zero. *)

    BEGIN
        BlockFill (ADR(v), n, 0);
    END ClearBlock;

(************************************************************************)

PROCEDURE BytesToWord (VAR (*IN*) b: ARRAY OF CARD8;  i: CARDINAL): CARD32;

    (* Convert four-byte substring, starting at b[i] to CARD32. *)

    VAR w: BigEndian;
        j: CARDINAL;

    BEGIN
        FOR j := 3 TO 0 BY -1 DO
            w.byte[j] := b[i];
            INC (i);
        END (*FOR*);
        RETURN w.word;
    END BytesToWord;

(************************************************************************)

PROCEDURE WordToBytes (n: CARD32;  VAR (*OUT*) b: ARRAY OF CARD8;  i: CARDINAL);

    (* Convert CARD32 to byte substring, starting at b[i]. *)

    VAR w: BigEndian;
        j: CARDINAL;

    BEGIN
        w.word := n;
        FOR j := 3 TO 0 BY -1 DO
            b[i] := w.byte[j];
            INC (i);
        END (*FOR*);
    END WordToBytes;

(************************************************************************)

PROCEDURE Swap (VAR (*INOUT*) a, b: CARD32);

    (* Swaps its arguments.  *)

    VAR temp: CARD32;

    BEGIN
        temp := a; a := b; b := temp;
    END Swap;

(************************************************************************)
(*                    INITIAL AND FINAL PERMUTATIONS                    *)
(************************************************************************)

CONST
    IP = PermMap {
                 58, 50, 42, 34, 26, 18, 10, 2,
                 60, 52, 44, 36, 28, 20, 12, 4,
                 62, 54, 46, 38, 30, 22, 14, 6,
                 64, 56, 48, 40, 32, 24, 16, 8,
                 57, 49, 41, 33, 25, 17,  9, 1,
                 59, 51, 43, 35, 27, 19, 11, 3,
                 61, 53, 45, 37, 29, 21, 13, 5,
                 63, 55, 47, 39, 31, 23, 15, 7
                 };

    FP = PermMap {
                 40, 8, 48, 16, 56, 24, 64, 32,
                 39, 7, 47, 15, 55, 23, 63, 31,
                 38, 6, 46, 14, 54, 22, 62, 30,
                 37, 5, 45, 13, 53, 21, 61, 29,
                 36, 4, 44, 12, 52, 20, 60, 28,
                 35, 3, 43, 11, 51, 19, 59, 27,
                 34, 2, 42, 10, 50, 18, 58, 26,
                 33, 1, 41,  9, 49, 17, 57, 25
                 };

(************************************************************************)

PROCEDURE InitialPermutation (VAR (*INOUT*) X, Y: CARD32);

    (* Initial Permutation. *)

    BEGIN
        Permute (X, Y, IP);
    END InitialPermutation;

(************************************************************************)

PROCEDURE FinalPermutation (VAR (*INOUT*) X, Y: CARD32);

    (* Initial Permutation. *)

    BEGIN
        Permute (X, Y, FP);
    END FinalPermutation;

(************************************************************************)
(*                          THE S PERMUTATIONS                          *)
(* The S-boxes in the standard are 4x16 arrays, which map a 6-bit       *)
(* number to a 4-bit result via a function that creates array indices   *)
(* from the 6-bit numbers.  I have chosen to use a different kind of    *)
(* S-box, that uses direct table lookup to get the result.  This uses   *)
(* more space, mostly because I'm using a 32-bit number to hold a       *)
(* shifted version of a 4-bit number, but it improves calculation speed.*)
(************************************************************************)

TYPE
    SBox = ARRAY [0..63] OF CARD32;
    STable = ARRAY [0..7] OF SBox;

CONST
    SVal = STable{
                  {
                  0E0000000H, 000000000H, 040000000H, 0F0000000H, 0D0000000H, 070000000H, 010000000H, 040000000H,
                  020000000H, 0E0000000H, 0F0000000H, 020000000H, 0B0000000H, 0D0000000H, 080000000H, 010000000H,
                  030000000H, 0A0000000H, 0A0000000H, 060000000H, 060000000H, 0C0000000H, 0C0000000H, 0B0000000H,
                  050000000H, 090000000H, 090000000H, 050000000H, 000000000H, 030000000H, 070000000H, 080000000H,
                  040000000H, 0F0000000H, 010000000H, 0C0000000H, 0E0000000H, 080000000H, 080000000H, 020000000H,
                  0D0000000H, 040000000H, 060000000H, 090000000H, 020000000H, 010000000H, 0B0000000H, 070000000H,
                  0F0000000H, 050000000H, 0C0000000H, 0B0000000H, 090000000H, 030000000H, 070000000H, 0E0000000H,
                  030000000H, 0A0000000H, 0A0000000H, 000000000H, 050000000H, 060000000H, 000000000H, 0D0000000H}
                  ,
                  {
                  0F000000H, 03000000H, 01000000H, 0D000000H, 08000000H, 04000000H, 0E000000H, 07000000H,
                  06000000H, 0F000000H, 0B000000H, 02000000H, 03000000H, 08000000H, 04000000H, 0E000000H,
                  09000000H, 0C000000H, 07000000H, 00000000H, 02000000H, 01000000H, 0D000000H, 0A000000H,
                  0C000000H, 06000000H, 00000000H, 09000000H, 05000000H, 0B000000H, 0A000000H, 05000000H,
                  00000000H, 0D000000H, 0E000000H, 08000000H, 07000000H, 0A000000H, 0B000000H, 01000000H,
                  0A000000H, 03000000H, 04000000H, 0F000000H, 0D000000H, 04000000H, 01000000H, 02000000H,
                  05000000H, 0B000000H, 08000000H, 06000000H, 0C000000H, 07000000H, 06000000H, 0C000000H,
                  09000000H, 00000000H, 03000000H, 05000000H, 02000000H, 0E000000H, 0F000000H, 09000000H}
                  ,
                  {
                  00A00000H, 00D00000H, 00000000H, 00700000H, 00900000H, 00000000H, 00E00000H, 00900000H,
                  00600000H, 00300000H, 00300000H, 00400000H, 00F00000H, 00600000H, 00500000H, 00A00000H,
                  00100000H, 00200000H, 00D00000H, 00800000H, 00C00000H, 00500000H, 00700000H, 00E00000H,
                  00B00000H, 00C00000H, 00400000H, 00B00000H, 00200000H, 00F00000H, 00800000H, 00100000H,
                  00D00000H, 00100000H, 00600000H, 00A00000H, 00400000H, 00D00000H, 00900000H, 00000000H,
                  00800000H, 00600000H, 00F00000H, 00900000H, 00300000H, 00800000H, 00000000H, 00700000H,
                  00B00000H, 00400000H, 00100000H, 00F00000H, 00200000H, 00E00000H, 00C00000H, 00300000H,
                  00500000H, 00B00000H, 00A00000H, 00500000H, 00E00000H, 00200000H, 00700000H, 00C00000H}
                  ,
                  {
                  00070000H, 000D0000H, 000D0000H, 00080000H, 000E0000H, 000B0000H, 00030000H, 00050000H,
                  00000000H, 00060000H, 00060000H, 000F0000H, 00090000H, 00000000H, 000A0000H, 00030000H,
                  00010000H, 00040000H, 00020000H, 00070000H, 00080000H, 00020000H, 00050000H, 000C0000H,
                  000B0000H, 00010000H, 000C0000H, 000A0000H, 00040000H, 000E0000H, 000F0000H, 00090000H,
                  000A0000H, 00030000H, 00060000H, 000F0000H, 00090000H, 00000000H, 00000000H, 00060000H,
                  000C0000H, 000A0000H, 000B0000H, 00010000H, 00070000H, 000D0000H, 000D0000H, 00080000H,
                  000F0000H, 00090000H, 00010000H, 00040000H, 00030000H, 00050000H, 000E0000H, 000B0000H,
                  00050000H, 000C0000H, 00020000H, 00070000H, 00080000H, 00020000H, 00040000H, 000E0000H}
                  ,
                  {
                  00002000H, 0000E000H, 0000C000H, 0000B000H, 00004000H, 00002000H, 00001000H, 0000C000H,
                  00007000H, 00004000H, 0000A000H, 00007000H, 0000B000H, 0000D000H, 00006000H, 00001000H,
                  00008000H, 00005000H, 00005000H, 00000000H, 00003000H, 0000F000H, 0000F000H, 0000A000H,
                  0000D000H, 00003000H, 00000000H, 00009000H, 0000E000H, 00008000H, 00009000H, 00006000H,
                  00004000H, 0000B000H, 00002000H, 00008000H, 00001000H, 0000C000H, 0000B000H, 00007000H,
                  0000A000H, 00001000H, 0000D000H, 0000E000H, 00007000H, 00002000H, 00008000H, 0000D000H,
                  0000F000H, 00006000H, 00009000H, 0000F000H, 0000C000H, 00000000H, 00005000H, 00009000H,
                  00006000H, 0000A000H, 00003000H, 00004000H, 00000000H, 00005000H, 0000E000H, 00003000H}
                  ,
                  {
                  00000C00H, 00000A00H, 00000100H, 00000F00H, 00000A00H, 00000400H, 00000F00H, 00000200H,
                  00000900H, 00000700H, 00000200H, 00000C00H, 00000600H, 00000900H, 00000800H, 00000500H,
                  00000000H, 00000600H, 00000D00H, 00000100H, 00000300H, 00000D00H, 00000400H, 00000E00H,
                  00000E00H, 00000000H, 00000700H, 00000B00H, 00000500H, 00000300H, 00000B00H, 00000800H,
                  00000900H, 00000400H, 00000E00H, 00000300H, 00000F00H, 00000200H, 00000500H, 00000C00H,
                  00000200H, 00000900H, 00000800H, 00000500H, 00000C00H, 00000F00H, 00000300H, 00000A00H,
                  00000700H, 00000B00H, 00000000H, 00000E00H, 00000400H, 00000100H, 00000A00H, 00000700H,
                  00000100H, 00000600H, 00000D00H, 00000000H, 00000B00H, 00000800H, 00000600H, 00000D00H}
                  ,
                  {
                  00000040H, 000000D0H, 000000B0H, 00000000H, 00000020H, 000000B0H, 000000E0H, 00000070H,
                  000000F0H, 00000040H, 00000000H, 00000090H, 00000080H, 00000010H, 000000D0H, 000000A0H,
                  00000030H, 000000E0H, 000000C0H, 00000030H, 00000090H, 00000050H, 00000070H, 000000C0H,
                  00000050H, 00000020H, 000000A0H, 000000F0H, 00000060H, 00000080H, 00000010H, 00000060H,
                  00000010H, 00000060H, 00000040H, 000000B0H, 000000B0H, 000000D0H, 000000D0H, 00000080H,
                  000000C0H, 00000010H, 00000030H, 00000040H, 00000070H, 000000A0H, 000000E0H, 00000070H,
                  000000A0H, 00000090H, 000000F0H, 00000050H, 00000060H, 00000000H, 00000080H, 000000F0H,
                  00000000H, 000000E0H, 00000050H, 00000020H, 00000090H, 00000030H, 00000020H, 000000C0H}
                  ,
                  {
                  0000000DH, 00000001H, 00000002H, 0000000FH, 00000008H, 0000000DH, 00000004H, 00000008H,
                  00000006H, 0000000AH, 0000000FH, 00000003H, 0000000BH, 00000007H, 00000001H, 00000004H,
                  0000000AH, 0000000CH, 00000009H, 00000005H, 00000003H, 00000006H, 0000000EH, 0000000BH,
                  00000005H, 00000000H, 00000000H, 0000000EH, 0000000CH, 00000009H, 00000007H, 00000002H,
                  00000007H, 00000002H, 0000000BH, 00000001H, 00000004H, 0000000EH, 00000001H, 00000007H,
                  00000009H, 00000004H, 0000000CH, 0000000AH, 0000000EH, 00000008H, 00000002H, 0000000DH,
                  00000000H, 0000000FH, 00000006H, 0000000CH, 0000000AH, 00000009H, 0000000DH, 00000000H,
                  0000000FH, 00000003H, 00000003H, 00000005H, 00000005H, 00000006H, 00000008H, 0000000BH}
                 };

(************************************************************************)
(*                          THE FEISTEL FUNCTION                        *)
(************************************************************************)

CONST
    (* This map produces a 48-bit result, which explains the 0 entries. *)

    Eselection = PermMap  { 0, 0, 0, 0, 0, 0, 0, 0,
                            0, 0, 0, 0, 0, 0, 0, 0,
                           32,  1,  2,  3,  4,  5,
                            4,  5,  6,  7,  8,  9,
                            8,  9, 10, 11, 12, 13,
                           12, 13, 14, 15, 16, 17,
                           16, 17, 18, 19, 20, 21,
                           20, 21, 22, 23, 24, 25,
                           24, 25, 26, 27, 28, 29,
                           28, 29, 30, 31, 32,  1};

    (* And this one maps from a 32-bit value to another 32-bit value. *)

    Ptable = PermMap32 {16,  7, 20, 21, 29, 12, 28, 17,
                         1, 15, 23, 26,  5, 18, 31, 10,
                         2,  8, 24, 14, 32, 27,  3,  9,
                        19, 13, 30,  6, 22, 11,  4, 25};

(************************************************************************)

PROCEDURE f (VAR (*INOUT*) R: CARD32;  key1, key2: CARD32): CARD32;

    (* The f() function in the standard. *)

    VAR TL, TR, carry, j, result: CARD32;

    BEGIN
        (* Convert the 32-bit R into a permuted 48-bit number,  *)
        (* then take the XOR with the 48-bit key.               *)

        TL := R;  TR := 0;
        Permute (TL, TR, Eselection);
        TL := IXOR (TL, key1);
        TR := IXOR (TR, key2);

        (* At this point (TL,TR) is a 48-bit number. We break it down   *)
        (* into eight 6-bit blocks.  Then we use the S-transformations  *)
        (* to turn the 6-bit numbers into 4-bit results, and we         *)
        (* rebuild those eight 4-bit blocks into a 32-bit number.       *)

        result := 0;
        FOR j := 7 TO 0 BY -1 DO
            result := result + SVal[j][IAND(TR, 63)];
            (* Right shift (TL,TR) by 6 bits. *)
            carry := IAND(TL, 63);
            TL := RS(TL, 6);
            TR := RS(TR, 6) + LS(carry, 26);
        END (*FOR*);

        Permute32 (result, Ptable);
        RETURN result;
    END f;

(************************************************************************)

PROCEDURE OneRound (VAR (*INOUT*) L, R: CARD32;  key1, key2: CARD32);

    (* Perform one round of the DES operation. *)

    VAR oldL: CARD32;

    BEGIN
        oldL := L;
        L := R;
        R := IXOR (oldL, f(R, key1, key2));
    END OneRound;

(************************************************************************)
(*                    ENCRYPTING/DECRYPTING ONE BLOCK                   *)
(************************************************************************)

PROCEDURE EncryptBlock (ctx: DEScontext;  VAR (*IN*) input: ARRAY OF CARD8;
                                    VAR (*INOUT*) inpos: CARDINAL);

    (* DES-ECB block encryption/decryption.  The same procedure is used *)
    (* for both encryption and decryption; the difference lies in what  *)
    (* was specified when opening the session.  Processes one block of  *)
    (* 8 bytes, and leaves the result in ctx^.outbuff.                  *)

    VAR j, k: CARDINAL;
        L, R: CARD32;
        key: DES3KeySchedule;
        currentinput: EightByte;

    BEGIN
        key := ctx^.KS;

        IF ctx^.CBC THEN

            (* Remark: the CBC operation would be more efficient if     *)
            (* done on the CARD32 values L and R, but for now I am wary *)
            (* 0f errors caused by bigendian/littleendian confusion.    *)

            IF ctx^.decrypt THEN

                FOR j := 0 TO 7 DO
                    currentinput[j] := input[inpos+j];
                END (*FOR*);

            ELSE

                FOR j := 0 TO 7 DO
                    input[inpos+j] := IXORB (input[inpos+j], ctx^.lastciphertext[j]);
                END (*FOR*);

            END (*IF*);
        END (*IF*);

        (* The main cipher operation starts here. *)

        L := BytesToWord (input, inpos);  INC (inpos, 4);
        R := BytesToWord (input, inpos);  INC (inpos, 4);

        InitialPermutation (L, R);

        k := 0;

        FOR j := 0 TO 15 DO
            OneRound (L, R, key[k], key[k+1]);
            INC (k, 2);
        END (*FOR*);

        IF ctx^.longkey THEN
            Swap (L, R);

            FOR j := 0 TO 15 DO
                OneRound (L, R, key[k], key[k+1]);
                INC (k, 2);
            END (*FOR*);

            Swap (L, R);

            FOR j := 0 TO 15 DO
                OneRound (L, R, key[k], key[k+1]);
                INC (k, 2);
            END (*FOR*);

        END (*IF*);

        (* To simulate the effect of the final (L,R) swap, we just  *)
        (* reverse the roles of L and R in the following.           *)

        FinalPermutation (R, L);

        WordToBytes (R, ctx^.outbuff, 0);
        WordToBytes (L, ctx^.outbuff, 4);

        IF ctx^.CBC THEN

            (* Remark: the CBC operation would be more efficient if     *)
            (* done on the CARD32 values L and R, but for now I am wary *)
            (* 0f errors caused by bigendian/littleendian confusion.    *)

            IF ctx^.decrypt THEN

                FOR j := 0 TO 7 DO
                    ctx^.outbuff[j] := IXORB (ctx^.outbuff[j], ctx^.lastciphertext[j]);
                END (*FOR*);
                ctx^.lastciphertext := currentinput;

            ELSE

                FOR j := 0 TO 7 DO
                    ctx^.lastciphertext[j] := ctx^.outbuff[j];
                END (*FOR*);

            END (*IF*);
        END (*IF*);

    END EncryptBlock;

(************************************************************************)
(*                           KEY EXPANSION                              *)
(************************************************************************)

PROCEDURE ROL28 (X: CARD32): CARD32;

    (* Rotate left a 28-bit number. *)

    CONST topbit = 8000000H;

    VAR result: CARD32;  carry: BOOLEAN;

    BEGIN
        carry := IAND(X, topbit) <> 0;
        result := X;
        IF carry THEN result := IXOR(result, topbit) END (*IF*);
        result := LS (result, 1);
        IF carry THEN INC (result) END (*IF*);
        RETURN result;
    END ROL28;

(************************************************************************)

CONST
    (* PC1 maps the initial 64-bit key to two 28-bit numbers C and D.   *)
    (* The non-obvious formatting is because I'm fitting a 28-bit       *)
    (* result into a 32-bit number, but for ease of checking I still    *)
    (* want to keep the 4x7 layout used in the standard.                *)

    PC1 = PermMap {
                    0, 0, 0, 0,
                    57, 49, 41, 33, 25, 17,  9,
                     1, 58, 50, 42, 34, 26, 18,
                    10,  2, 59, 51, 43, 35, 27,
                    19, 11,  3, 60, 52, 44, 36,
                    0, 0, 0, 0,
                    63, 55, 47, 39, 31, 23, 15,
                     7, 62, 54, 46, 38, 30, 22,
                    14,  6, 61, 53, 45, 37, 29,
                    21, 13,  5, 28, 20, 12,  4
                  };

    (* PC2 maps the 56-bit pair (C,D) to a 48-bit result in the key     *)
    (* schedule.  The table in the standard assumes in effect that      *)
    (* (C,D) is sitting in a pair of 28-bit registers.  To fix this,    *)
    (* we have to take the original table, and increase each value by   *)
    (* 8 for table values > 28, or by 4 otherwise.  I've used a         *)
    (* spreadsheet to do this, and here is the result.  (This           *)
    (* complication would not have arisen with little-endian notation.) *)

    PC2 = PermMap {
                  0, 0, 0, 0, 0, 0, 0, 0,
                  0, 0, 0, 0, 0, 0, 0, 0,
                  18,  21,  15,  28,   5,   9,
                   7,  32,  19,  10,  25,  14,
                  27,  23,  16,  8,   30,  12,
                  20,  11,  31,  24,  17,   6,
                  49,  60,  39,  45,  55,  63,
                  38,  48,  59,  53,  41,  56,
                  52,  57,  47,  64,  42,  61,
                  54,  50,  58,  44,  37,  40
                  };

(************************************************************************)

PROCEDURE SetKey1 (VAR (*OUT*) KS: ARRAY OF CARD32;  VAR (*INOUT*) outpos: CARDINAL;
                                key: ARRAY OF CARD8;  VAR (*INOUT*) keypos: CARDINAL);

    (* Expands the 8-byte key, starting at key[keypos], out to 32       *)
    (* words, starting at KS[outpos].  Both subscripts are updated.     *)
    (* The key schedule for DES is actually supposed to be an array of  *)
    (* 16 48-bit words, but it is easier for us to store those as pairs *)
    (* of 32-bit words.                                                 *)

    (* Remark: the original key is 64 bits, but we use only 48 of them. *)
    (* The other 8 are in principle used to give odd parity, although   *)
    (* this implementation simply ignores the parity bits.  In a        *)
    (* departure from usual practice, the parity bits are the low-order *)
    (* bits of each byte - this is a consequence of the big-endian      *)
    (* assumptions in the DES standard.                                 *)

    VAR C, D, X, Y: CARD32;  round: CARDINAL;

    BEGIN
        C := BytesToWord (key, keypos);  INC (keypos, 4);
        D := BytesToWord (key, keypos);  INC (keypos, 4);
        Permute (C, D, PC1);
        FOR round := 1 TO 16 DO
            C := ROL28(C);  D := ROL28(D);
            IF (round > 2) AND (round <> 9) AND (round <> 16) THEN
                C := ROL28(C);  D := ROL28(D);
            END (*IF*);
            X := C;  Y := D;
            Permute (X, Y, PC2);
            KS[outpos] := X;  INC (outpos);
            KS[outpos] := Y;  INC (outpos);
        END (*FOR*);
    END SetKey1;

(************************************************************************)

PROCEDURE SetEncryptionKey (decrypt: BOOLEAN;
                                    VAR (*OUT*) KS: DES3KeySchedule;
                                    N: CARDINAL;  key: ARRAY OF CARD8)
                                                                : BOOLEAN;

    (* Common code for the DES and DES3 encryption and decryption key   *)
    (* schedules; see comments for DESOpen.                             *)

    (* The resulting key schedule is 96 words long if the returned      *)
    (* value is TRUE, and 32 words long otherwise.                      *)

    VAR outpos, keypos, j: CARDINAL;
        longkey: BOOLEAN;
        fullkey: ARRAY [0..23] OF CARD8;

    BEGIN
        longkey := TRUE;
        IF N >= 24 THEN
            Copy (ADR(key), ADR(fullkey), 24);
        ELSIF N >= 16 THEN
            Copy (ADR(key), ADR(fullkey), 16);
            Copy (ADR(key), ADR(fullkey[16]), 8);
        ELSE
            Copy (ADR(key), ADR(fullkey), 8);
            longkey := FALSE;
        END (*IF*);

        (* Now work out three key schedules. *)

        outpos := 0;  keypos := 0;
        SetKey1 (KS, outpos, fullkey, keypos);
        IF longkey THEN
            SetKey1 (KS, outpos, fullkey, keypos);
            SetKey1 (KS, outpos, fullkey, keypos);

            IF decrypt THEN
                (* Reverse the order in the two outer sets, to get decryption. *)

                FOR j := 0 TO 30 BY 2 DO
                    Swap (KS[j], KS[94-j]);
                    Swap (KS[j+1], KS[95-j]);
                END (*FOR*);

            ELSE
                (* Reverse the order in the centre set, to get decryption. *)

                FOR j := 32 TO 46 BY 2 DO
                    Swap (KS[j], KS[94-j]);
                    Swap (KS[j+1], KS[95-j]);
                END (*FOR*);

            END (*IF*);
        ELSE
            (* This is the DES rather than the DES3 case. *)

            IF decrypt THEN
                FOR j := 0 TO 15 BY 2 DO
                    Swap (KS[j], KS[30-j]);
                    Swap (KS[j+1], KS[31-j]);
                END (*FOR*);
            END (*IF*);

        END (*IF*);

        RETURN longkey;

    END SetEncryptionKey;

(************************************************************************)
(*                       THE END-USER PROCEDURES                        *)
(************************************************************************)

PROCEDURE DESopen (decrypt, fullpadding: BOOLEAN;  N: CARDINAL;
                                        key: ARRAY OF CARD8): DEScontext;

    (* Starts a new DES session.  The decrypt parameter is FALSE if we  *)
    (* are opening the session to do encryption, and TRUE for           *)
    (* decryption.  N is the length in bytes of the key.                *)
    (*                                                                  *)
    (* Slightly unconventionally, we do not have separate calls for     *)
    (* DES and DES3.  Instead, we choose which one to use based on the  *)
    (* key length N.  DES3 permits three variants:                      *)
    (*  - if the key is 24 bytes long (N=24) then we have the full DES3 *)
    (*    implementation with three independent 8-byte keys.            *)
    (*  - if the key is 16 bytes long (N=16) then we set the third      *)
    (*    8-byte key  equal to the first.                               *)
    (*  - if the supplied key is 8 bytes long (N=8) then we use DES     *)
    (*    instead of DES3.                                              *)
    (* It is easy to see that DES3 with three identical keys would      *)
    (* produce the same result as if we had used DES, so we have not    *)
    (* lost anything by dropping back to DES for this case.             *)

    VAR ctx: DEScontext;

    BEGIN
        NEW (ctx);
        ctx^.CBC := FALSE;
        ctx^.decrypt := decrypt;
        ctx^.fullpadding := fullpadding;
        ctx^.incount := 0;
        ctx^.deferred := FALSE;
        ctx^.longkey := SetEncryptionKey (decrypt, ctx^.KS, N, key);
        RETURN ctx;
    END DESopen;

(************************************************************************)

PROCEDURE DES_CBCopen (decrypt, fullpadding: BOOLEAN;  N: CARDINAL;
                                    key, IV: ARRAY OF CARD8): DEScontext;

    (* Like DESopen, but enables the Cipher Block Chaining (CBC) mode   *)
    (* of DES.  The extra parameter IV is the initialisation vector,    *)
    (* which is 8 bytes long.                                           *)

    VAR ctx: DEScontext;

    BEGIN
        ctx := DESopen (decrypt, fullpadding, N, key);
        ctx^.CBC := TRUE;
        Copy (ADR(IV), ADR(ctx^.lastciphertext), 8);
        RETURN ctx;
    END DES_CBCopen;

(************************************************************************)

PROCEDURE DumpKeySchedule (ctx: DEScontext);

    (* For testing: writes the key schedule to standard output. *)

    VAR j: CARDINAL;

    BEGIN
        WriteString ("Key schedule:");  WriteLn;
        FOR j := 0 TO 31 BY 2 DO
            WriteString ("    ");
            DumpWord (ctx^.KS[j]);  WriteChar (' ');  DumpWord (ctx^.KS[j+1]);
            IF ctx^.longkey THEN
                WriteString ("          ");
                DumpWord (ctx^.KS[j+32]);  WriteChar (' ');  DumpWord (ctx^.KS[j+33]);
                WriteString ("          ");
                DumpWord (ctx^.KS[j+64]);  WriteChar (' ');  DumpWord (ctx^.KS[j+65]);
            END (*IF*);
            WriteLn;
        END (*FOR*);
    END DumpKeySchedule;

(************************************************************************)

PROCEDURE DESEncrypt (ctx: DEScontext;  inputlength: CARDINAL;
                                     VAR (*IN*) input: ARRAY OF CARD8;
                                     VAR (*OUT*) output: ARRAY OF CARD8;
                                     VAR (*INOUT*) outpos: CARDINAL);

    (* DES-ECB or DES-CBC encryption/decryption.  The same procedure    *)
    (* is used for both encryption and decryption; the difference lies  *)
    (* in what was specified when opening the session.  Output is added *)
    (* starting at output[outpos], and outpos is updated to be ready    *)
    (* for the next call to this procedure.                             *)

    VAR inpos, pos, togo: CARDINAL;

    BEGIN
        inpos := 0;  togo := inputlength;

        WHILE togo > 0 DO

            (* Check for a full block that's been deferred. *)

            IF ctx^.deferred THEN
                Copy (ADR(ctx^.outbuff), ADR(output[outpos]), 8);
                INC (outpos, 8);
                ctx^.deferred := FALSE;
            END (*IF*);

            (* Check for input data left over from the last call. *)

            IF ctx^.incount > 0 THEN

                WHILE (ctx^.incount < 8) AND (togo > 0) DO
                    ctx^.inbuff[ctx^.incount] := input[inpos];
                    INC (inpos);  INC (ctx^.incount);  DEC (togo);
                END (*WHILE*);

                (* If we've now filled that block, process it.   *)

                IF ctx^.incount = 8 THEN
                    pos := 0;
                    EncryptBlock (ctx, ctx^.inbuff, pos);
                    IF ctx^.fullpadding AND ctx^.decrypt THEN
                        ctx^.deferred := TRUE;
                    ELSE
                        Copy (ADR(ctx^.outbuff), ADR(output[outpos]), 8);
                        INC (outpos, 8);
                    END (*IF*);
                    ctx^.incount := 0;
                END (*IF*);

            END (*IF*);

            (* The remaining cases: process the next 8 bytes if possible. *)
            (* If fewer than 8 bytes left, save them in inbuff.           *)

            IF togo < 8 THEN
                ctx^.incount := 0;
                WHILE togo > 0 DO
                    ctx^.inbuff[ctx^.incount] := input[inpos];
                    INC (inpos);  INC (ctx^.incount);  DEC (togo);
                END (*WHILE*);
            ELSE
                EncryptBlock (ctx, input, inpos);
                DEC (togo, 8);
                IF ctx^.fullpadding AND ctx^.decrypt THEN
                    ctx^.deferred := TRUE;
                ELSE
                    Copy (ADR(ctx^.outbuff), ADR(output[outpos]), 8);
                    INC (outpos, 8);
                END (*IF*);
            END (*IF*);

        END (*WHILE*);

    END DESEncrypt;

(************************************************************************)

PROCEDURE DESfinal (VAR (*INOUT*) ctx: DEScontext;
                            VAR (*OUT*) output: ARRAY OF CARD8;
                             VAR (*INOUT*) outpos: CARDINAL);

    (* Processes any remaining unsent data, adds or removes padding as  *)
    (* needed, then terminates the use of the key specified in DESopen. *)

    VAR j, k, padamount, pos: CARDINAL;
        paddata: CARD8;  error: BOOLEAN;

    BEGIN
        IF ctx <> NIL THEN
            IF ctx^.decrypt THEN

                (* DECRYPTION - we have to strip padding *)

                IF ctx^.deferred THEN

                    paddata := ctx^.outbuff[7];

                    IF ctx^.incount > 0 THEN
                        (* Partial block, should not happen. *)

                        error := TRUE;
                        k := 0;

                    ELSIF ctx^.fullpadding THEN

                        (* This block contains padding, so we have to work  *)
                        (* out how much, if any, is data we have to keep.   *)

                        error := FALSE;
                        k := 8 - paddata;
                        FOR j := k TO 7 DO
                            error := error OR (ctx^.outbuff[j] <> paddata);
                        END (*FOR*);
                    ELSE
                        (* We can't be certain about what padding, if any,  *)
                        (* has been used, so don't strip anything.          *)

                        error := TRUE;
                        k := 0;

                    END (*IF*);

                    (* If error, put out the whole block.      *)
                    (* Otherwise, send bytes 0..8-paddata-1.   *)

                    IF error THEN
                        j := 8;
                    ELSE
                        j := k;
                    END (*IF*);
                    IF j > 0 THEN
                        Copy (ADR(ctx^.outbuff), ADR(output[outpos]), j);
                        INC (outpos, j);
                    END (*IF*);

                END (*IF*);
            ELSE

                (* ENCRYPTION - we might have to add padding *)

                IF ctx^.fullpadding OR (ctx^.incount > 0) THEN
                    padamount := 8 - ctx^.incount;
                    IF ctx^.fullpadding THEN
                        paddata := padamount;
                    ELSE
                        paddata := 0;
                    END (*IF*);
                    IF padamount > 0 THEN
                        FOR j := ctx^.incount TO 7 DO
                            ctx^.inbuff[j] := paddata;
                        END (*FR*);
                    END (*IF*);
                    pos := 0;
                    EncryptBlock (ctx, ctx^.inbuff, pos);
                    Copy (ADR(ctx^.outbuff), ADR(output[outpos]), 8);
                    INC (outpos, 8);
                END (*IF*);

            END (*IF*);

            ClearBlock (ctx^.KS, SIZE(DES3KeySchedule));
            DISPOSE (ctx);
        END (*IF*);

    END DESfinal;

(************************************************************************)

END DES.

