---------------------------------------------------------------------- with Grammar_Constants; -- constants from the parser generator use Grammar_Constants; --| to gain visibility on ParserInteger's operations package body Lex_Identifier_Token_Value is --| Overview --| --| This perfect hash algorithm taken from --| "A Perfect Hash Function for Ada Reserved Words" --| by David Wolverton, published in Ada Letters Jul-Aug 1984 --| use Parsetables; package Pt renames Parsetables; ------------------------------------------------------------------ -- Declarations Local to Package Lex_Identifier_Token_Value ------------------------------------------------------------------ subtype Hashrange is Integer; subtype Hashidentifiersubrange is Hashrange range 0 .. 70; type Xlatearray is array (Character) of Hashrange; Xlate : constant Xlatearray := Xlatearray'('A' => 0, 'B' => 49, 'C' => 0, 'D' => -7, 'E' => -20, 'F' => 18, 'G' => -2, 'H' => -38, 'I' => 33, 'J' => 0, 'K' => -9, 'L' => 9, 'M' => 29, 'N' => -9, 'O' => 6, 'P' => 26, 'Q' => 0, 'R' => 8, 'S' => 1, 'T' => 1, 'U' => -9, 'V' => 0, 'W' => 56, 'X' => -28, 'Y' => 11, 'Z' => 0, others => 0); type Hashtablearray is array (Hashidentifiersubrange) of Parsetables.Tokenrange; --| Mapping from hash value into the token values. Hashtable : constant Hashtablearray := Hashtablearray'(40 => 2, -- ABORT 6 => 3, -- ABS 37 => 4, -- ACCEPT 43 => 5, -- ACCESS 34 => 6, -- ALL 22 => 7, -- AND 16 => 8, -- ARRAY 3 => 9, -- AT 61 => 10, -- BEGIN 70 => 11, -- BODY 20 => 12, -- CASE 35 => 13, -- CONSTANT 14 => 14, -- DECLARE 9 => 15, -- DELAY 36 => 16, -- DELTA 38 => 17, -- DIGITS 7 => 18, -- DO 0 => 19, -- ELSE 19 => 20, -- ELSIF 2 => 21, -- END 30 => 22, -- ENTRY 8 => 23, -- EXCEPTION 1 => 24, -- EXIT 57 => 25, -- FOR 45 => 26, -- FUNCTION 21 => 27, -- GENERIC 46 => 28, -- GOTO 69 => 29, -- IF 42 => 30, -- IN 52 => 31, -- IS 17 => 32, -- LIMITED 67 => 33, -- LOOP 53 => 34, -- MOD 58 => 35, -- NEW 23 => 36, -- NOT 26 => 37, -- NULL 54 => 38, -- OF 44 => 39, -- OR 47 => 40, -- OTHERS 50 => 41, -- OUT 25 => 42, -- PACKAGE 56 => 43, -- PRAGMA 51 => 44, -- PRIVATE 49 => 45, -- PROCEDURE 29 => 46, -- RAISE 5 => 47, -- RANGE 41 => 48, -- RECORD 48 => 49, -- REM 24 => 50, -- RENAMES 39 => 51, -- RETURN 31 => 52, -- REVERSE 12 => 53, -- SELECT 27 => 54, -- SEPARATE 18 => 55, -- SUBTYPE 32 => 56, -- TASK 28 => 57, -- TERMINATE 4 => 58, -- THEN 15 => 59, -- TYPE 10 => 60, -- USE 59 => 61, -- WHEN 63 => 62, -- WHILE 60 => 63, -- WITH 11 => 64, -- XOR others => Pt.Identifiertokenvalue); --| These are used to convert lower to upper case. Convert : array (Character) of Character; Difference : constant := Character'Pos ('a') - Character'Pos ('A'); ------------------------------------------------------------------ -- Subprogram Specifications Local to -- Package Lex_Identifier_Token_Value ------------------------------------------------------------------ function Normalizetouppercase ( --| normalize SYMREP to upper case In_String : in String) return String; ------------------------------------------------------------------ -- Subprogram Bodies Global to Package Lex_Identifier_Token_Value ------------------------------------------------------------------ procedure Find (In_Identifier : in String; Out_Token_Value : out Parsetables.Tokenrange) is subtype Id_String is String (In_Identifier'Range); In_Identifier_Normalized : Id_String; Length : Hashrange := In_Identifier_Normalized'Length; --| Length of string First : Hashrange := In_Identifier_Normalized'First; --| Lower bound Firstchar, Lastchar : Character; --| First and last characters Secondtolastchar : Character; --| Second to last character Secondtolast : Hashrange; --| Alphabetic position of 2nd to last char. Hashvalue : Hashrange; --| Perfect hash value. Tokenvalue : Parsetables.Grammarsymbolrange; begin In_Identifier_Normalized := Normalizetouppercase (In_Identifier); -- Assume In_Identifier is a plain identifier. Out_Token_Value := Pt.Identifiertokenvalue; if (Length <= 1) or else (Length >= 10) then -- Couldn't be a reserved word. return; else Firstchar := In_Identifier_Normalized (First); Lastchar := In_Identifier_Normalized ((First + Length) - 1); Secondtolastchar := In_Identifier_Normalized ((First + Length) - 2); Secondtolast := Character'Pos (Secondtolastchar) - Character'Pos ('A'); Hashvalue := Xlate (Firstchar) + Xlate (Lastchar) + 2 * Secondtolast + Length; end if; if Hashvalue in Hashidentifiersubrange then -- index and see if it matches a reserved word value. -- if so, then compare the string to the reserved word text. Tokenvalue := Parsetables.Grammarsymbolrange (Hashtable (Hashvalue)); -- conversion if Tokenvalue /= Pt.Identifiertokenvalue then if (In_Identifier_Normalized = Pt.Get_Grammar_Symbol (Tokenvalue)) then Out_Token_Value := Pt.Tokenrange (Tokenvalue); -- conversion end if; end if; end if; end Find; ------------------------------------------------------------------ -- Subprogram Bodies Local to -- Package Lex_Identifier_Token_Value ------------------------------------------------------------------ function Normalizetouppercase ( --| normalize SYMREP to upper case In_String : in String) return String is Outstring : String (In_String'Range); begin for I in In_String'Range loop Outstring (I) := Convert (In_String (I)); end loop; return Outstring; end Normalizetouppercase; ------------------------------------------------------------------ begin --| Initialize the conversion array for lower to upper case conversion for I in Character loop case I is when 'a' .. 'z' => Convert (I) := Character'Val (Character'Pos (I) - Difference); when others => Convert (I) := I; end case; end loop; ------------------------------------------------------------------ end Lex_Identifier_Token_Value; ----------------------------------------------------------------------