diff options
Diffstat (limited to 'gcc/ada/g-sha1.adb')
| -rw-r--r-- | gcc/ada/g-sha1.adb | 379 |
1 files changed, 379 insertions, 0 deletions
diff --git a/gcc/ada/g-sha1.adb b/gcc/ada/g-sha1.adb new file mode 100644 index 00000000000..72b19244a36 --- /dev/null +++ b/gcc/ada/g-sha1.adb @@ -0,0 +1,379 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S H A 1 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2006, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT 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 distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the code for this unit is derived from GNAT.MD5 + +with Ada.Unchecked_Conversion; + +package body GNAT.SHA1 is + + use Interfaces; + + Padding : constant String := + (1 => Character'Val (16#80#), 2 .. 64 => ASCII.NUL); + + Hex_Digit : constant array (Unsigned_32 range 0 .. 15) of Character := + ('0', '1', '2', '3', '4', '5', '6', '7', + '8', '9', 'a', 'b', 'c', 'd', 'e', 'f'); + -- Look-up table for each hex digit of the Message-Digest. + -- Used by function Digest (Context). + + type Sixteen_Words is array (Natural range 0 .. 15) + of Interfaces.Unsigned_32; + -- Sixteen 32-bit words, converted from block of 64 characters. + -- Used in procedure Decode and Transform. + + procedure Decode (Block : String; X : out Sixteen_Words); + -- Convert a String of 64 characters into 16 32-bit numbers + + -- The following functions are the four elementary components of each + -- of the four round groups (0 .. 19, 20 .. 39, 40 .. 59, and 60 .. 79) + -- defined in RFC 3174. + + function F0 (B, C, D : Unsigned_32) return Unsigned_32; + pragma Inline (F0); + + function F1 (B, C, D : Unsigned_32) return Unsigned_32; + pragma Inline (F1); + + function F2 (B, C, D : Unsigned_32) return Unsigned_32; + pragma Inline (F2); + + function F3 (B, C, D : Unsigned_32) return Unsigned_32; + pragma Inline (F3); + + procedure Transform (Ctx : in out Context; Block : String); + -- Process one block of 64 characters + + ------------ + -- Decode -- + ------------ + + procedure Decode (Block : String; X : out Sixteen_Words) is + Cur : Positive := Block'First; + + begin + pragma Assert (Block'Length = 64); + + for Index in X'Range loop + X (Index) := + Unsigned_32 (Character'Pos (Block (Cur + 3))) + + Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 2))), 8) + + Shift_Left (Unsigned_32 (Character'Pos (Block (Cur + 1))), 16) + + Shift_Left (Unsigned_32 (Character'Pos (Block (Cur))), 24); + Cur := Cur + 4; + end loop; + end Decode; + + ------------ + -- Digest -- + ------------ + + function Digest (C : Context) return Message_Digest is + Result : Message_Digest; + + Cur : Natural := 1; + -- Index in Result where the next character will be placed + + Last_Block : String (1 .. 64); + + C1 : Context := C; + + procedure Convert (X : Unsigned_32); + -- Put the contribution of one of the five H words of the Context in + -- Result. Increments Cur. + + ------------- + -- Convert -- + ------------- + + procedure Convert (X : Unsigned_32) is + Y : Unsigned_32 := X; + begin + for J in 1 .. 8 loop + Y := Rotate_Left (Y, 4); + Result (Cur) := Hex_Digit (Y and Unsigned_32'(16#0F#)); + Cur := Cur + 1; + end loop; + end Convert; + + -- Start of processing for Digest + + begin + -- Process characters in the context buffer, if any + + pragma Assert (C.Last /= C.Buffer'Last); + Last_Block (1 .. C.Last) := C.Buffer (1 .. C.Last); + + if C.Last > 55 then + Last_Block (C.Last + 1 .. 64) := Padding (1 .. 64 - C.Last); + Transform (C1, Last_Block); + Last_Block := (others => ASCII.NUL); + + else + Last_Block (C.Last + 1 .. 56) := Padding (1 .. 56 - C.Last); + end if; + + -- Add the input length (as stored in the context) as 8 characters + + Last_Block (57 .. 64) := (others => ASCII.NUL); + + declare + L : Unsigned_64 := Unsigned_64 (C.Length) * 8; + Idx : Positive := 64; + begin + while L > 0 loop + Last_Block (Idx) := Character'Val (L and 16#Ff#); + L := Shift_Right (L, 8); + Idx := Idx - 1; + end loop; + end; + + Transform (C1, Last_Block); + + Convert (C1.H (0)); + Convert (C1.H (1)); + Convert (C1.H (2)); + Convert (C1.H (3)); + Convert (C1.H (4)); + return Result; + end Digest; + + function Digest (S : String) return Message_Digest is + C : Context; + begin + Update (C, S); + return Digest (C); + end Digest; + + function Digest + (A : Ada.Streams.Stream_Element_Array) return Message_Digest + is + C : Context; + begin + Update (C, A); + return Digest (C); + end Digest; + + -------- + -- F0 -- + -------- + + function F0 + (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 + is + begin + return (B and C) or ((not B) and D); + end F0; + + -------- + -- F1 -- + -------- + + function F1 + (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 + is + begin + return B xor C xor D; + end F1; + + -------- + -- F2 -- + -------- + + function F2 + (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 + is + begin + return (B and C) or (B and D) or (C and D); + end F2; + + -------- + -- F3 -- + -------- + + function F3 + (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 + renames F1; + + --------------- + -- Transform -- + --------------- + + procedure Transform + (Ctx : in out Context; + Block : String) + is + W : array (0 .. 79) of Interfaces.Unsigned_32; + + A, B, C, D, E, Temp : Interfaces.Unsigned_32; + + begin + pragma Assert (Block'Length = 64); + + -- a. Divide data block into sixteen words + + Decode (Block, Sixteen_Words (W (0 .. 15))); + + -- b. Prepare working block of 80 words + + for T in 16 .. 79 loop + + -- W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16)) + + W (T) := Rotate_Left + (W (T - 3) xor W (T - 8) xor W (T - 14) xor W (T - 16), 1); + + end loop; + + -- c. Set up transformation variables + + A := Ctx.H (0); + B := Ctx.H (1); + C := Ctx.H (2); + D := Ctx.H (3); + E := Ctx.H (4); + + -- d. For each of the 80 rounds, compute: + + -- TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t); + -- E = D; D = C; C = S^30(B); B = A; A = TEMP; + + for T in 0 .. 19 loop + Temp := Rotate_Left (A, 5) + F0 (B, C, D) + E + W (T) + 16#5A827999#; + E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp; + end loop; + + for T in 20 .. 39 loop + Temp := Rotate_Left (A, 5) + F1 (B, C, D) + E + W (T) + 16#6ED9EBA1#; + E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp; + end loop; + + for T in 40 .. 59 loop + Temp := Rotate_Left (A, 5) + F2 (B, C, D) + E + W (T) + 16#8F1BBCDC#; + E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp; + end loop; + + for T in 60 .. 79 loop + Temp := Rotate_Left (A, 5) + F3 (B, C, D) + E + W (T) + 16#CA62C1D6#; + E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp; + end loop; + + -- e. Update context: + -- H0 = H0 + A, H1 = H1 + B, H2 = H2 + C, H3 = H3 + D, H4 = H4 + E + + Ctx.H (0) := Ctx.H (0) + A; + Ctx.H (1) := Ctx.H (1) + B; + Ctx.H (2) := Ctx.H (2) + C; + Ctx.H (3) := Ctx.H (3) + D; + Ctx.H (4) := Ctx.H (4) + E; + end Transform; + + ------------ + -- Update -- + ------------ + + procedure Update + (C : in out Context; + Input : String) + is + Inp : constant String := C.Buffer (1 .. C.Last) & Input; + Cur : Positive := Inp'First; + + begin + C.Length := C.Length + Input'Length; + + while Cur + 63 <= Inp'Last loop + Transform (C, Inp (Cur .. Cur + 63)); + Cur := Cur + 64; + end loop; + + C.Last := Inp'Last - Cur + 1; + C.Buffer (1 .. C.Last) := Inp (Cur .. Inp'Last); + end Update; + + procedure Update + (C : in out Context; + Input : Ada.Streams.Stream_Element_Array) + is + subtype Stream_Array is Ada.Streams.Stream_Element_Array (Input'Range); + subtype Stream_String is + String (1 + Integer (Input'First) .. 1 + Integer (Input'Last)); + + function To_String is new Ada.Unchecked_Conversion + (Stream_Array, Stream_String); + + String_Input : constant String := To_String (Input); + begin + Update (C, String_Input); + end Update; + + ----------------- + -- Wide_Digest -- + ----------------- + + function Wide_Digest (W : Wide_String) return Message_Digest is + C : Context; + begin + Wide_Update (C, W); + return Digest (C); + end Wide_Digest; + + ----------------- + -- Wide_Update -- + ----------------- + + procedure Wide_Update + (C : in out Context; + Input : Wide_String) + is + String_Input : String (1 .. 2 * Input'Length); + Cur : Positive := 1; + + begin + for Index in Input'Range loop + String_Input (Cur) := + Character'Val + (Unsigned_32 (Wide_Character'Pos (Input (Index))) and 16#FF#); + Cur := Cur + 1; + String_Input (Cur) := + Character'Val + (Shift_Right (Unsigned_32 (Wide_Character'Pos (Input (Index))), 8) + and 16#FF#); + Cur := Cur + 1; + end loop; + + Update (C, String_Input); + end Wide_Update; + +end GNAT.SHA1; |