ADDED src/natools-string_slices.adb Index: src/natools-string_slices.adb ================================================================== --- src/natools-string_slices.adb +++ src/natools-string_slices.adb @@ -0,0 +1,376 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2013, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +package body Natools.String_Slices is + + use type String_Refs.Reference; + + + ----------------------------- + -- String_Range primitives -- + ----------------------------- + + function Is_In (Point : Natural; Reference : String_Range) return Boolean is + begin + return Point >= Reference.First + and Point < Reference.First + Reference.Length; + end Is_In; + + + function Is_Subrange (Sample, Reference : String_Range) return Boolean is + begin + return Sample.First >= Reference.First + and then Sample.First + Sample.Length + <= Reference.First + Reference.Length; + end Is_Subrange; + + + function Last (Self : String_Range) return Natural is + begin + return Self.First + Self.Length - 1; + end Last; + + + function To_Range (First : Positive; Last : Natural) return String_Range is + begin + if Last >= First then + return (First => First, Length => Last - First + 1); + else + return (First => First, Length => 0); + end if; + end To_Range; + + + function Get_Range (S : String) return String_Range is + begin + return (S'First, S'Length); + end Get_Range; + + + procedure Set_First (Self : in out String_Range; New_First : in Positive) is + begin + if New_First >= Self.First + Self.Length then + Self.Length := 0; + else + Self.Length := Self.Length - (New_First - Self.First); + end if; + + Self.First := New_First; + end Set_First; + + + procedure Set_Last (Self : in out String_Range; New_Last : in Natural) is + begin + if New_Last < Self.First then + Self.Length := 0; + else + Self.Length := New_Last - Self.First + 1; + end if; + end Set_Last; + + + procedure Set_Length + (Self : in out String_Range; New_Length : in Natural) is + begin + Self.Length := New_Length; + end Set_Length; + + + function Image (Interval : String_Range) return String is + First_Img : String := Integer'Image (Interval.First); + begin + pragma Assert (First_Img (First_Img'First) = ' '); + + if Interval.Length = 0 then + return "empty at" & First_Img; + end if; + + First_Img (First_Img'First) := '['; + + if Interval.Length = 1 then + return First_Img & ']'; + else + return First_Img + & ',' + & Integer'Image (Last (Interval)) + & ']'; + end if; + end Image; + + + + -------------------------- + -- Conversion functions -- + -------------------------- + + function To_Slice (S : String) return Slice is + function Create return String; + + function Create return String is + begin + return S; + end Create; + begin + return Slice'(Bounds => (S'First, S'Length), + Ref => String_Refs.Create (Create'Access)); + end To_Slice; + + + function To_String (S : Slice) return String is + begin + if S.Ref.Is_Empty then + return ""; + else + return S.Ref.Query.Data.all (S.Bounds.First .. Last (S.Bounds)); + end if; + end To_String; + + + + --------------- + -- Accessors -- + --------------- + + procedure Export (S : in Slice; Output : out String) is + begin + if not S.Ref.Is_Empty then + Output := S.Ref.Query.Data.all (S.Bounds.First .. Last (S.Bounds)); + end if; + end Export; + + + procedure Query + (S : in Slice; + Process : not null access procedure (Text : in String)) is + begin + if S.Bounds.Length = 0 or else S.Ref.Is_Empty then + Process.all (""); + else + Process.all + (S.Ref.Query.Data.all (S.Bounds.First .. Last (S.Bounds))); + end if; + end Query; + + + function Get_Range (S : Slice) return String_Range is + begin + return S.Bounds; + end Get_Range; + + + function First (S : Slice) return Positive is + begin + return S.Bounds.First; + end First; + + + function Last (S : Slice) return Natural is + begin + return Last (S.Bounds); + end Last; + + + function Length (S : Slice) return Natural is + begin + return S.Bounds.Length; + end Length; + + + + --------------- + -- Extenders -- + --------------- + + function Parent (S : Slice) return Slice is + begin + if S.Ref.Is_Empty then + return Slice'(others => <>); + else + return Slice'(Bounds => Get_Range (S.Ref.Query.Data.all), + Ref => S.Ref); + end if; + end Parent; + + + function Extend (S : Slice; New_Range : in String_Range) return Slice is + begin + if not Is_Subrange (New_Range, Get_Range (S.Ref.Query.Data.all)) then + raise Constraint_Error with "Extend slice beyond complete range"; + end if; + + return Slice'(Bounds => New_Range, + Ref => S.Ref); + end Extend; + + + function Extend (S : Slice; First : Positive; Last : Natural) + return Slice is + begin + return Extend (S, To_Range (First, Last)); + end Extend; + + + procedure Extend (S : in out Slice; New_Range : in String_Range) is + begin + if not Is_Subrange (New_Range, Get_Range (S.Ref.Query.Data.all)) then + raise Constraint_Error with "Extend slice beyond complete range"; + end if; + + S.Bounds := New_Range; + end Extend; + + + procedure Extend + (S : in out Slice; First : in Positive; Last : in Natural) is + begin + Extend (S, To_Range (First, Last)); + end Extend; + + + + ----------------- + -- Restrictors -- + ----------------- + + function Subslice (S : Slice; New_Range : String_Range) return Slice is + begin + if S.Ref.Is_Empty then + if New_Range.Length = 0 then + return Slice'(Bounds => New_Range, Ref => <>); + else + raise Constraint_Error with "Subslice of null slice"; + end if; + end if; + + if not Is_Subrange (New_Range, S.Bounds) then + raise Constraint_Error with "Subslice out of parent range"; + end if; + + return Slice'(Bounds => New_Range, + Ref => S.Ref); + end Subslice; + + + function Subslice (S : Slice; First : Positive; Last : Natural) + return Slice is + begin + return Subslice (S, To_Range (First, Last)); + end Subslice; + + + procedure Restrict (S : in out Slice; New_Range : in String_Range) is + begin + if S.Ref.Is_Empty and New_Range.Length /= 0 then + raise Constraint_Error with "Restrict of null slice"; + end if; + + if not Is_Subrange (New_Range, S.Bounds) then + raise Constraint_Error with "Restriction with not a subrange"; + end if; + + S.Bounds := New_Range; + end Restrict; + + + procedure Restrict + (S : in out Slice; First : in Positive; Last : in Natural) is + begin + Restrict (S, To_Range (First, Last)); + end Restrict; + + + procedure Set_First (S : in out Slice; New_First : in Positive) is + begin + if New_First < S.Bounds.First then + raise Constraint_Error with "New_First out of slice range"; + end if; + + Set_First (S.Bounds, New_First); + end Set_First; + + + procedure Set_Last (S : in out Slice; New_Last : in Natural) is + begin + if New_Last > Last (S.Bounds) then + raise Constraint_Error with "New_Last out of slice range"; + end if; + + Set_Last (S.Bounds, New_Last); + end Set_Last; + + + procedure Set_Length (S : in out Slice; New_Length : in Natural) is + begin + if New_Length > S.Bounds.Length then + raise Constraint_Error with "New_Length out of slice range"; + end if; + + S.Bounds.Length := New_Length; + end Set_Length; + + + + ---------------------- + -- Slice comparison -- + ---------------------- + + function Is_Empty (S : Slice) return Boolean is + begin + return S.Bounds.Length = 0 or else S.Ref.Is_Empty; + end Is_Empty; + + + function Is_Null (S : Slice) return Boolean is + begin + return S.Ref.Is_Empty; + end Is_Null; + + + function Is_Related (Left, Right : Slice) return Boolean is + begin + return Left.Ref = Right.Ref; + end Is_Related; + + + function Is_Subslice (S, Reference : Slice) return Boolean is + begin + return S.Ref = Reference.Ref + and then Is_Subrange (S.Bounds, Reference.Bounds); + end Is_Subslice; + + + + ------------------ + -- Constructors -- + ------------------ + + function Duplicate (S : Slice) return Slice is + function Factory return String; + + function Factory return String is + begin + return S.Ref.Query.Data.all; + end Factory; + begin + if S.Bounds.Length = 0 or else S.Ref.Is_Empty then + return Null_Slice; + else + return Slice'(Bounds => S.Bounds, + Ref => String_Refs.Create (Factory'Access)); + end if; + end Duplicate; + +end Natools.String_Slices; ADDED src/natools-string_slices.ads Index: src/natools-string_slices.ads ================================================================== --- src/natools-string_slices.ads +++ src/natools-string_slices.ads @@ -0,0 +1,195 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2013, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.String_Slices provide an object that represents a substring of a -- +-- shared parent string. -- +------------------------------------------------------------------------------ + +private with Natools.References; + +package Natools.String_Slices is + pragma Preelaborate (String_Slices); + + ----------------------- + -- String range type -- + ----------------------- + + type String_Range is record + First : Positive; + Length : Natural; + end record; + + function Is_In (Point : Natural; Reference : String_Range) return Boolean; + function Is_Subrange (Sample, Reference : String_Range) return Boolean; + -- Inclusion tests + + function Last (Self : String_Range) return Natural; + -- Return last bound of the given range + + function To_Range (First : Positive; Last : Natural) return String_Range; + -- Create a range with the given bounds + + function Get_Range (S : String) return String_Range; + -- Return the String_Range representation of S index range. + -- Semantically equivalent to (To_Range (S'First, S'Last)) + -- and to (String_Range'(First => S'First, Length => S'Length)). + + procedure Set_First (Self : in out String_Range; New_First : in Positive); + -- Update first bound keeping last bound intact + + procedure Set_Last (Self : in out String_Range; New_Last : in Natural); + -- Update range for the given last bound, keeping the first one intact + + procedure Set_Length (Self : in out String_Range; New_Length : in Natural); + -- Basic mutator included for completeness sake + + function Image (Interval : String_Range) return String; + -- Interval representation of the given range + + + ---------------- + -- Slice type -- + ---------------- + + type Slice is tagged private; + + Null_Slice : constant Slice; + + + -------------------------- + -- Conversion functions -- + -------------------------- + + function To_Slice (S : String) return Slice; + -- Create a new slice containing the whole given string + + function To_String (S : Slice) return String; + -- Return the string represented by the slice + + + --------------- + -- Accessors -- + --------------- + + procedure Export (S : in Slice; Output : out String); + -- Fill Output with string contents in S + -- Raise Constraint_Error when Output'Length /= Length(S) + + procedure Query + (S : in Slice; + Process : not null access procedure (Text : in String)); + -- Query the string object directly from memory + + function Get_Range (S : Slice) return String_Range; + -- Return the range embedded in S + + function First (S : Slice) return Positive; + -- Return the lowest index of S + + function Last (S : Slice) return Natural; + -- Return the largest index of S + + function Length (S : Slice) return Natural; + -- Return the length of S + + + --------------- + -- Extenders -- + --------------- + + -- These subprograms allow access to the parent string beyond the + -- current range. However Constraint_Error is raised when trying to reach + -- beyond the parent string range. + + function Parent (S : Slice) return Slice; + -- Return a slice representing the whole string available + + function Extend (S : Slice; New_Range : in String_Range) return Slice; + function Extend (S : Slice; First : Positive; Last : Natural) return Slice; + procedure Extend (S : in out Slice; New_Range : in String_Range); + procedure Extend (S : in out Slice; First : in Positive; Last : in Natural); + -- Extend the range represented by S + + + ----------------- + -- Restrictors -- + ----------------- + + -- All the subprograms here raise Constraint_Error when the new range + -- is not a subrange of the source range. + + function Subslice (S : Slice; New_Range : String_Range) return Slice; + function Subslice (S : Slice; First : Positive; Last : Natural) + return Slice; + -- Return a subslice of S + + procedure Restrict (S : in out Slice; New_Range : in String_Range); + procedure Restrict + (S : in out Slice; First : in Positive; Last : in Natural); + -- Update the range in S + + procedure Set_First (S : in out Slice; New_First : in Positive); + -- Update the range of S keeping the upper bound intact + + procedure Set_Last (S : in out Slice; New_Last : in Natural); + -- Update the range of S keeping the lower bound intact + + procedure Set_Length (S : in out Slice; New_Length : in Natural); + -- Truncate S range to the given length, keeping the lower bound intact + + + ---------------------- + -- Slice comparison -- + ---------------------- + + function Is_Empty (S : Slice) return Boolean; + -- Return whether the slice represents an empty string. + -- Semantically equivalent to (To_String (S) = ""). + + function Is_Null (S : Slice) return Boolean; + -- Return whether the slice has a parent string + + function Is_Related (Left, Right : Slice) return Boolean; + -- Return whether both slices have the same parent string + + function Is_Subslice (S, Reference : Slice) return Boolean; + -- Return whether S represent of a subrange of Reference with the + -- same parent string. + + function Duplicate (S : Slice) return Slice; + -- Create a new parent string and a slice designating it. + -- This does not copy parts of S parent string outside of S range. + -- Semantically equivalent to (To_Slice (To_String (S))). + +private + + type Access_In_Default_Pool is access Boolean; + -- Access type only used to infer default storage pool + + package String_Refs is new References + (String, + Access_In_Default_Pool'Storage_Pool, + Access_In_Default_Pool'Storage_Pool); + + type Slice is tagged record + Bounds : String_Range := (1, 0); + Ref : String_Refs.Reference; + end record; + + Null_Slice : constant Slice := ((1, 0), Ref => <>); + +end Natools.String_Slices;