From dc3078a06b5ee52751cfb6fd6cf13b3790632ac4 Mon Sep 17 00:00:00 2001
From: Jed Barber <jjbarber@y7mail.com>
Date: Sat, 12 Jan 2019 00:38:45 +1100
Subject: Packrat.Lexer.Combinators specs and tests complete

---
 src/packrat-lexer.adb  | 91 ++++++++++++++++++++++++++++++++++++++++++++------
 src/packrat-lexer.ads  | 14 +++++---
 src/packrat-tokens.adb | 18 ++++++----
 3 files changed, 101 insertions(+), 22 deletions(-)

(limited to 'src')

diff --git a/src/packrat-lexer.adb b/src/packrat-lexer.adb
index f93b65b..0b0f571 100644
--- a/src/packrat-lexer.adb
+++ b/src/packrat-lexer.adb
@@ -1,8 +1,17 @@
 
 
+with
+
+    Ada.Unchecked_Deallocation;
+
+
 package body Packrat.Lexer is
 
 
+    procedure Free_Array is new Ada.Unchecked_Deallocation
+        (Object => Element_Array, Name => Element_Array_Access);
+
+
     procedure Initialize
            (This : in out Combinator_Result) is
     begin
@@ -13,14 +22,24 @@ package body Packrat.Lexer is
     procedure Adjust
            (This : in out Combinator_Result) is
     begin
-        null;
+        if This.Value /= null then
+            declare
+                New_Array : Element_Array_Access :=
+                    new Element_Array (1 .. This.Value.all'Length);
+            begin
+                New_Array.all := This.Value.all;
+                This.Value := New_Array;
+            end;
+        end if;
     end Adjust;
 
 
     procedure Finalize
            (This : in out Combinator_Result) is
     begin
-        null;
+        if This.Value /= null then
+            Free_Array (This.Value);
+        end if;
     end Finalize;
 
 
@@ -31,26 +50,78 @@ package body Packrat.Lexer is
            (Length : in Natural;
             Status : in Result_Status;
             Value  : in Element_Array)
-        return Combinator_Result is
+        return Combinator_Result
+    is
+        This : Combinator_Result;
     begin
-        return Fail_Result;
+        This.Length := Length;
+        This.Status := Status;
+        This.Value := new Element_Array (1 .. Value'Length);
+        This.Value.all := Value;
+        return This;
     end Create_Result;
 
 
     function Join
            (Left, Right : in Combinator_Result)
-        return Combinator_Result is
+        return Combinator_Result
+    is
+        Merge : Combinator_Result;
+        Left_Valsize, Right_Valsize, Total_Valsize : Natural;
     begin
-        return Fail_Result;
+        if Left.Value /= null then
+            Left_Valsize := Left.Value.all'Length;
+        else
+            Left_Valsize := 0;
+        end if;
+        if Right.Value /= null then
+            Right_Valsize := Right.Value.all'Length;
+        else
+            Right_Valsize := 0;
+        end if;
+        Total_Valsize := Left_Valsize + Right_Valsize;
+
+        if Left.Status = Success then
+            Merge.Length := Left.Length + Right.Length;
+            Merge.Status := Right.Status;
+            if Total_Valsize /= 0 or Right.Status /= Failure then
+                Merge.Value := new Element_Array (1 .. Total_Valsize);
+                if Left_Valsize /= 0 then
+                    Merge.Value.all (1 .. Left_Valsize) := Left.Value.all;
+                end if;
+                if Right_Valsize /= 0 then
+                    Merge.Value.all (Left_Valsize + 1 .. Total_Valsize) := Right.Value.all;
+                end if;
+            end if;
+            return Merge;
+        else
+            return Left;
+        end if;
     end Join;
 
 
-    function Is_Failure
+    function "="
+           (Left, Right : in Combinator_Result)
+        return Boolean
+    is
+        Null_Check : Boolean :=
+            Left.Value = null and Right.Value = null;
+        Value_Check : Boolean :=
+            Left.Value /= null and then Right.Value /= null and then
+            Left.Value.all = Right.Value.all;
+    begin
+        return Left.Length = Right.Length and
+            Left.Status = Right.Status and
+            (Null_Check or Value_Check);
+    end "=";
+
+
+    function Status
            (This : in Combinator_Result)
-        return Boolean is
+        return Result_Status is
     begin
-        return True;
-    end Is_Failure;
+        return This.Status;
+    end Status;
 
 
 end Packrat.Lexer;
diff --git a/src/packrat-lexer.ads b/src/packrat-lexer.ads
index 81c9d2a..ef08cb5 100644
--- a/src/packrat-lexer.ads
+++ b/src/packrat-lexer.ads
@@ -11,11 +11,11 @@ generic
 package Packrat.Lexer is
 
 
-    type Combinator_Result is private;
+    type Combinator_Result is new Ada.Finalization.Controlled with private;
 
     type Combinator is access function
-           (Input  : in     Element_Array;
-            Start  : in     Positive)
+           (Input : in Element_Array;
+            Start : in Positive)
         return Combinator_Result;
 
     type Combinator_Array is array (Positive range <>) of Combinator;
@@ -34,10 +34,14 @@ package Packrat.Lexer is
            (Left, Right : in Combinator_Result)
         return Combinator_Result;
 
-    function Is_Failure
-           (This : in Combinator_Result)
+    function "="
+           (Left, Right : in Combinator_Result)
         return Boolean;
 
+    function Status
+           (This : in Combinator_Result)
+        return Result_Status;
+
 
 private
 
diff --git a/src/packrat-tokens.adb b/src/packrat-tokens.adb
index 70a866a..240ecee 100644
--- a/src/packrat-tokens.adb
+++ b/src/packrat-tokens.adb
@@ -30,13 +30,17 @@ package body Tokens is
 
 
     procedure Adjust
-           (This : in out Token)
-    is
-        New_Array : Element_Array_Access :=
-            new Element_Array (This.Token_Value'Range);
+           (This : in out Token) is
     begin
-        New_Array.all := This.Token_Value.all;
-        This.Token_Value := New_Array;
+        if This.Token_Value /= null then
+            declare
+                New_Array : Element_Array_Access :=
+                    new Element_Array (1 .. This.Token_Value'Length);
+            begin
+                New_Array.all := This.Token_Value.all;
+                This.Token_Value := New_Array;
+            end;
+        end if;
     end Adjust;
 
 
@@ -64,7 +68,7 @@ package body Tokens is
         This.Identifier := Ident;
         This.Start_At := Start;
         This.Finish_At := Finish;
-        This.Token_Value := new Element_Array (Value'Range);
+        This.Token_Value := new Element_Array (1 .. Value'Length);
         This.Token_Value.all := Value;
         return This;
     end Create;
-- 
cgit