with Ada.Characters.Latin_1, Ada.Strings.Maps, Packrat.Lexer.Combinators, Packrat.Util; package body Ratnest.Tests is package Latin renames Ada.Characters.Latin_1; package Strmaps renames Ada.Strings.Maps; package PE renames Packrat.Errors; package PU renames Packrat.Util; function Valid_Message_Check return Test_Result is begin if PE.Valid_Message ("abcde") or PE.Valid_Message ("sSYM") or PE.Valid_Message ("sSYMp") or PE.Valid_Message ("p345") or PE.Valid_Message ("pOne") or PE.Valid_Message ("sSYMp1sNEXT") or PE.Valid_Message ("sSYMp1.2") or PE.Valid_Message ("sABcDp12") or not PE.Valid_Message ("sSYMp0") or not PE.Valid_Message ("sAp12") or not PE.Valid_Message ("sNAMEp34sSYMp02") or not PE.Valid_Message ("") or not PE.Valid_Message ("sA_Bp3") or not PE.Valid_Message ("sAp1sAp1") then return Failure; end if; return Success; end Valid_Message_Check; function Valid_Identifier_Check return Test_Result is Pass_Array : PE.Error_Info_Array := ((+"A", 1), (+"ABC", 2), (+"AB_CD", 3), (+"A_B_CD", 4)); Fail_Array : PE.Error_Info_Array := ((+"_", 1), (+"_A", 2), (+"A_", 3), (+"A__B", 4), (+"A%B", 3)); begin for EI of Pass_Array loop if not PE.Valid_Identifier (EI.Symbol) or not PE.Valid_Identifier (-EI.Symbol) then return Failure; end if; end loop; for EI of Fail_Array loop if PE.Valid_Identifier (EI.Symbol) or PE.Valid_Identifier (-EI.Symbol) then return Failure; end if; end loop; if not PE.Valid_Identifier_Array (Pass_Array) or PE.Valid_Identifier_Array (Fail_Array) then return Failure; end if; return Success; end Valid_Identifier_Check; function Join_Check return Test_Result is Array_1 : PE.Error_Info_Array := ((+"A", 1), (+"B", 2)); Msg_1 : PE.Error_Message := PE.Encode_Array (Array_1); Array_2 : PE.Error_Info_Array := ((+"C", 3), (+"D", 4)); Msg_2 : PE.Error_Message := PE.Encode_Array (Array_2); Msg_3 : PE.Error_Message := PE.Join (Msg_1, Msg_2); Array_4 : PE.Error_Info_Array := ((+"A", 1), (+"B", 2), (+"C", 3), (+"D", 4)); Msg_4 : PE.Error_Message := PE.Encode_Array (Array_4); Array_5 : PE.Error_Info_Array := ((+"A", 1), (+"B", 4)); Msg_5 : PE.Error_Message := PE.Encode_Array (Array_5); Array_6 : PE.Error_Info_Array := ((+"A", 1), (+"C", 3)); Msg_6 : PE.Error_Message := PE.Encode_Array (Array_6); Msg_7 : PE.Error_Message := PE.Join (Msg_5, Msg_6); Array_8 : PE.Error_Info_Array := ((+"A", 1), (+"B", 4), (+"C", 3)); Msg_8 : PE.Error_Message := PE.Encode_Array (Array_8); begin if Msg_3 /= Msg_4 or Msg_7 /= Msg_8 then return Failure; end if; return Success; end Join_Check; function Encode_1_Check return Test_Result is begin -- Encode with a String and a Natural if PE.Encode ("ABC", 15) /= "sABCp15" then return Failure; end if; return Success; end Encode_1_Check; function Encode_2_Check return Test_Result is begin -- Encode with an Unbounded_String and a Natural if PE.Encode (+"ABC", 15) /= "sABCp15" then return Failure; end if; return Success; end Encode_2_Check; function Encode_3_Check return Test_Result is begin -- Encode with an Error_Info if PE.Encode ((+"ABC", 15)) /= "sABCp15" then return Failure; end if; return Success; end Encode_3_Check; function Encode_4_Check return Test_Result is begin -- Encode with an Error_Info_Array if PE.Encode_Array (((+"A", 3), (+"BC", 2), (+"ABC", 1), (+"B", 4))) /= "sAp3sBCp2sABCp1sBp4" then return Failure; end if; return Success; end Encode_4_Check; function Decode_Check return Test_Result is use type PE.Error_Info_Array; begin if PE.Decode ("sAp1sBp3sCp10sDEFp456") /= ((+"A", 1), (+"B", 3), (+"C", 10), (+"DEF", 456)) then return Failure; end if; return Success; end Decode_Check; function Token_Adjust_Check return Test_Result is type My_Labels is (One, Two, Three); package My_Tokens is new Packrat.Tokens (My_Labels, Character, String); A : My_Tokens.Token; begin declare B : My_Tokens.Token := My_Tokens.Create (One, 1, 3, "abc"); begin A := B; end; if not A.Initialized or else A.Value /= "abc" then return Failure; end if; return Success; end Token_Adjust_Check; function Token_Store_Check return Test_Result is type My_Labels is (One, Two, Three); package My_Tokens is new Packrat.Tokens (My_Labels, Character, String); T : My_Tokens.Token := My_Tokens.Create (One, 1, 3, "abc"); begin if not T.Initialized or else T.Label /= One or else T.Start /= 1 or else T.Finish /= 3 or else T.Value /= "abc" then return Failure; end if; return Success; end Token_Store_Check; function Lex_Sequence_Check return Test_Result is begin return Failure; end Lex_Sequence_Check; function Lex_Count_Check return Test_Result is begin return Failure; end Lex_Count_Check; function Lex_Many_Check return Test_Result is begin return Failure; end Lex_Many_Check; function Lex_Many_Until_Check return Test_Result is begin return Failure; end Lex_Many_Until_Check; function Lex_Satisfy_Check return Test_Result is begin return Failure; end Lex_Satisfy_Check; function Lex_Satisfy_With_Check return Test_Result is begin return Failure; end Lex_Satisfy_With_Check; function Lex_Match_Check return Test_Result is begin return Failure; end Lex_Match_Check; function Lex_Match_With_Check return Test_Result is begin return Failure; end Lex_Match_With_Check; function Lex_Multimatch_Check return Test_Result is begin return Failure; end Lex_Multimatch_Check; function Lex_Take_Check return Test_Result is begin return Failure; end Lex_Take_Check; function Lex_Take_While_Check return Test_Result is begin return Failure; end Lex_Take_While_Check; function Lex_Take_Until_Check return Test_Result is begin return Failure; end Lex_Take_Until_Check; function Line_Start_Check return Test_Result is begin return Failure; end Line_Start_Check; function Line_End_Check return Test_Result is begin return Failure; end Line_End_Check; function Input_Start_Check return Test_Result is begin return Failure; end Input_Start_Check; function Input_End_Check return Test_Result is begin return Failure; end Input_End_Check; function In_Set_Check return Test_Result is use type Strmaps.Character_Set; Set_1 : Strmaps.Character_Set := Strmaps.To_Set ("abcxyz"); Set_2 : Strmaps.Character_Set := Strmaps.To_Set ("!""#$"); function Func_1 is new PU.In_Set (Set_1); function Func_2 is new PU.In_Set (Set_2); begin -- Func_1 testing for I in Integer range Character'Pos (Character'First) .. Character'Pos ('a') - 1 loop if Func_1 (Character'Val (I)) then return Failure; end if; end loop; for C in Character range 'a' .. 'c' loop if not Func_1 (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('c') + 1 .. Character'Pos ('x') - 1 loop if Func_1 (Character'Val (I)) then return Failure; end if; end loop; for C in Character range 'x' .. 'z' loop if not Func_1 (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('z') + 1 .. Character'Pos (Character'Last) loop if Func_1 (Character'Val (I)) then return Failure; end if; end loop; -- Func_2 testing for I in Integer range Character'Pos (Character'First) .. Character'Pos ('!') - 1 loop if Func_2 (Character'Val (I)) then return Failure; end if; end loop; for C in Character range '!' .. '$' loop if not Func_2 (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('$') + 1 .. Character'Pos (Character'Last) loop if Func_2 (Character'Val (I)) then return Failure; end if; end loop; return Success; end In_Set_Check; function Not_In_Set_Check return Test_Result is use type Strmaps.Character_Set; Set_1 : Strmaps.Character_Set := Strmaps.To_Set ("abcxyz"); Set_2 : Strmaps.Character_Set := Strmaps.To_Set ("!""#$"); function Func_1 is new PU.Not_In_Set (Set_1); function Func_2 is new PU.Not_In_Set (Set_2); begin -- Func_1 testing for I in Integer range Character'Pos (Character'First) .. Character'Pos ('a') - 1 loop if not Func_1 (Character'Val (I)) then return Failure; end if; end loop; for C in Character range 'a' .. 'c' loop if Func_1 (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('c') + 1 .. Character'Pos ('x') - 1 loop if not Func_1 (Character'Val (I)) then return Failure; end if; end loop; for C in Character range 'x' .. 'z' loop if Func_1 (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('z') + 1 .. Character'Pos (Character'Last) loop if not Func_1 (Character'Val (I)) then return Failure; end if; end loop; -- Func_2 testing for I in Integer range Character'Pos (Character'First) .. Character'Pos ('!') - 1 loop if not Func_2 (Character'Val (I)) then return Failure; end if; end loop; for C in Character range '!' .. '$' loop if Func_2 (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('$') + 1 .. Character'Pos (Character'Last) loop if not Func_2 (Character'Val (I)) then return Failure; end if; end loop; return Success; end Not_In_Set_Check; function Is_Digit_Check return Test_Result is begin for I in Integer range Character'Pos (Character'First) .. Character'Pos ('0') - 1 loop if PU.Is_Digit (Character'Val (I)) then return Failure; end if; end loop; for C in Character range '0' .. '9' loop if not PU.Is_Digit (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('9') + 1 .. Character'Pos (Character'Last) loop if PU.Is_Digit (Character'Val (I)) then return Failure; end if; end loop; return Success; end Is_Digit_Check; function Is_Hex_Check return Test_Result is begin for I in Integer range Character'Pos (Character'First) .. Character'Pos ('0') - 1 loop if PU.Is_Hex (Character'Val (I)) then return Failure; end if; end loop; for C in Character range '0' .. '9' loop if not PU.Is_Hex (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('9') + 1 .. Character'Pos ('A') - 1 loop if PU.Is_Hex (Character'Val (I)) then return Failure; end if; end loop; for C in Character range 'A' .. 'F' loop if not PU.Is_Hex (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('F') + 1 .. Character'Pos ('a') - 1 loop if PU.Is_Hex (Character'Val (I)) then return Failure; end if; end loop; for C in Character range 'a' .. 'f' loop if not PU.Is_Hex (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('f') + 1 .. Character'Pos (Character'Last) loop if PU.Is_Hex (Character'Val (I)) then return Failure; end if; end loop; return Success; end Is_Hex_Check; function Is_Letter_Check return Test_Result is begin for I in Integer range Character'Pos (Character'First) .. Character'Pos ('A') - 1 loop if PU.Is_Letter (Character'Val (I)) then return Failure; end if; end loop; for C in Character range 'A' .. 'Z' loop if not PU.Is_Letter (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('Z') + 1 .. Character'Pos ('a') - 1 loop if PU.Is_Letter (Character'Val (I)) then return Failure; end if; end loop; for C in Character range 'a' .. 'z' loop if not PU.Is_Letter (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('z') + 1 .. Character'Pos (Character'First) loop if PU.Is_Letter (Character'Val (I)) then return Failure; end if; end loop; return Success; end Is_Letter_Check; function Is_Alphanumeric_Check return Test_Result is begin for I in Integer range Character'Pos (Character'First) .. Character'Pos ('0') - 1 loop if PU.Is_Alphanumeric (Character'Val (I)) then return Failure; end if; end loop; for C in Character range '0' .. '9' loop if not PU.Is_Alphanumeric (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('9') + 1 .. Character'Pos ('A') - 1 loop if PU.Is_Alphanumeric (Character'Val (I)) then return Failure; end if; end loop; for C in Character range 'A' .. 'Z' loop if not PU.Is_Alphanumeric (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('Z') + 1 .. Character'Pos ('a') - 1 loop if PU.Is_Alphanumeric (Character'Val (I)) then return Failure; end if; end loop; for C in Character range 'a' .. 'z' loop if not PU.Is_Alphanumeric (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('z') + 1 .. Character'Pos (Character'Last) loop if PU.Is_Alphanumeric (Character'Val (I)) then return Failure; end if; end loop; return Success; end Is_Alphanumeric_Check; function Is_Punctuation_Check return Test_Result is begin for I in Integer range Character'Pos (Character'First) .. Character'Pos ('!') - 1 loop if PU.Is_Punctuation (Character'Val (I)) then return Failure; end if; end loop; for C in Character range '!' .. '/' loop if not PU.Is_Punctuation (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('/') + 1 .. Character'Pos (':') - 1 loop if PU.Is_Punctuation (Character'Val (I)) then return Failure; end if; end loop; for C in Character range ':' .. '@' loop if not PU.Is_Punctuation (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('@') + 1 .. Character'Pos ('[') - 1 loop if PU.Is_Punctuation (Character'Val (I)) then return Failure; end if; end loop; for C in Character range '[' .. '`' loop if not PU.Is_Punctuation (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('`') + 1 .. Character'Pos ('{') - 1 loop if PU.Is_Punctuation (Character'Val (I)) then return Failure; end if; end loop; for C in Character range '{' .. '~' loop if not PU.Is_Punctuation (C) then return Failure; end if; end loop; for I in Integer range Character'Pos ('~') + 1 .. Character'Pos (Character'Last) loop if PU.Is_Punctuation (Character'Val (I)) then return Failure; end if; end loop; return Success; end Is_Punctuation_Check; function Is_ASCII_Check return Test_Result is begin for I in Integer range Character'Pos (Character'First) .. 127 loop if not PU.Is_ASCII (Character'Val (I)) then return Failure; end if; end loop; for I in Integer range 128 .. Character'Pos (Character'Last) loop if PU.Is_ASCII (Character'Val (I)) then return Failure; end if; end loop; return Success; end Is_ASCII_Check; function Is_Extended_ASCII_Check return Test_Result is begin for I in Integer range Character'Pos (Character'First) .. 127 loop if PU.Is_Extended_ASCII (Character'Val (I)) then return Failure; end if; end loop; for I in Integer range 128 .. Character'Pos (Character'Last) loop if not PU.Is_Extended_ASCII (Character'Val (I)) then return Failure; end if; end loop; return Success; end Is_Extended_ASCII_Check; function Is_Space_Check return Test_Result is begin for I in Integer range Character'Pos (Character'First) .. Character'Pos (' ') - 1 loop if PU.Is_Space (Character'Val (I)) then return Failure; end if; end loop; if not PU.Is_Space (' ') then return Failure; end if; for I in Integer range Character'Pos (' ') + 1 .. Character'Pos (Character'Last) loop if PU.Is_Space (Character'Val (I)) then return Failure; end if; end loop; return Success; end Is_Space_Check; function Is_Linespace_Check return Test_Result is begin for I in Integer range Character'Pos (Character'First) .. Character'Pos (Latin.HT) - 1 loop if PU.Is_Linespace (Character'Val (I)) then return Failure; end if; end loop; if not PU.Is_Linespace (Latin.HT) then return Failure; end if; for I in Integer range Character'Pos (Latin.HT) + 1 .. Character'Pos (' ') - 1 loop if PU.Is_Linespace (Character'Val (I)) then return Failure; end if; end loop; if not PU.Is_Linespace (' ') then return Failure; end if; for I in Integer range Character'Pos (' ') + 1 .. Character'Pos (Character'Last) loop if PU.Is_Linespace (Character'Val (I)) then return Failure; end if; end loop; return Success; end Is_Linespace_Check; function Is_End_Of_Line_Check return Test_Result is begin for I in Integer range Character'Pos (Character'First) .. Character'Pos (Latin.LF) - 1 loop if PU.Is_End_Of_Line (Character'Val (I)) then return Failure; end if; end loop; if not PU.Is_End_Of_Line (Latin.LF) then return Failure; end if; for I in Integer range Character'Pos (Latin.LF) + 1 .. Character'Pos (Latin.CR) - 1 loop if PU.Is_End_Of_Line (Character'Val (I)) then return Failure; end if; end loop; if not PU.Is_End_Of_Line (Latin.CR) then return Failure; end if; for I in Integer range Character'Pos (Latin.CR) + 1 .. Character'Pos (Character'Last) loop if PU.Is_End_Of_Line (Character'Val (I)) then return Failure; end if; end loop; return Success; end Is_End_Of_Line_Check; function Is_Whitespace_Check return Test_Result is begin for I in Integer range Character'Pos (Character'First) .. Character'Pos (Latin.HT) - 1 loop if PU.Is_Whitespace (Character'Val (I)) then return Failure; end if; end loop; for C in Character range Latin.HT .. Latin.LF loop if not PU.Is_Whitespace (C) then return Failure; end if; end loop; for I in Integer range Character'Pos (Latin.LF) + 1 .. Character'Pos (Latin.CR) - 1 loop if PU.Is_Whitespace (Character'Val (I)) then return Failure; end if; end loop; if not PU.Is_Whitespace (Latin.CR) then return Failure; end if; for I in Integer range Character'Pos (Latin.CR) + 1 .. Character'Pos (' ') - 1 loop if PU.Is_Whitespace (Character'Val (I)) then return Failure; end if; end loop; if not PU.Is_Whitespace (' ') then return Failure; end if; for I in Integer range Character'Pos (' ') + 1 .. Character'Pos (Character'Last) loop if PU.Is_Whitespace (Character'Val (I)) then return Failure; end if; end loop; return Success; end Is_Whitespace_Check; function Not_Whitespace_Check return Test_Result is begin for I in Integer range Character'Pos (Character'First) .. Character'Pos (Latin.HT) - 1 loop if not PU.Not_Whitespace (Character'Val (I)) then return Failure; end if; end loop; for C in Character range Latin.HT .. Latin.LF loop if PU.Not_Whitespace (C) then return Failure; end if; end loop; for I in Integer range Character'Pos (Latin.LF) + 1 .. Character'Pos (Latin.CR) - 1 loop if not PU.Not_Whitespace (Character'Val (I)) then return Failure; end if; end loop; if PU.Not_Whitespace (Latin.CR) then return Failure; end if; for I in Integer range Character'Pos (Latin.CR) + 1 .. Character'Pos (' ') - 1 loop if not PU.Not_Whitespace (Character'Val (I)) then return Failure; end if; end loop; if PU.Not_Whitespace (' ') then return Failure; end if; for I in Integer range Character'Pos (' ') + 1 .. Character'Pos (Character'Last) loop if not PU.Not_Whitespace (Character'Val (I)) then return Failure; end if; end loop; return Success; end Not_Whitespace_Check; end Ratnest.Tests;