ada.2/types-sequences.adb

   1 with Err;
   2 with Types.Fns;
   3 with Types.Builtins;
   4
   5 package body Types.Sequences is
   6
   7    function "=" (Left, Right : in Instance) return Boolean is
   8       --  Should become Left.all.Data = Right.all.Data when
   9       --  https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89178 is fixed.
  10    begin
  11       return Left.Length = Right.Length
  12         and then
  13         (for all I in 1 .. Left.Data'Length => Left.Data (I) = Right.Data (I));
  14    end "=";
  15
  16    function Concat (Args : in T_Array) return T is
  17       Sum   : Natural  := 0;
  18       First : Positive := 1;
  19       Last  : Natural;
  20    begin
  21       Err.Check ((for all A of Args => A.Kind in Kind_Sequence),
  22                  "expected sequences");
  23       for Arg of Args loop
  24          Sum := Sum + Arg.Sequence.all.Data'Length;
  25       end loop;
  26       declare
  27          Ref : constant Sequence_Ptr := Constructor (Sum);
  28       begin
  29          for Arg of Args loop
  30             Last := First - 1 + Arg.Sequence.all.Data'Last;
  31             Ref.all.Data (First .. Last) := Arg.Sequence.all.Data;
  32             First := Last + 1;
  33          end loop;
  34          return (Kind_List, Ref);
  35       end;
  36    end Concat;
  37
  38    function Conj (Args : in T_Array) return T is
  39    begin
  40       Err.Check (0 < Args'Length, "expected at least 1 parameter");
  41       case Args (Args'First).Kind is
  42       when Kind_Sequence =>
  43          declare
  44             Data : T_Array renames Args (Args'First).Sequence.all.Data;
  45             Last : constant Natural := Args'Length - 1 + Data'Length;
  46             --  Avoid exceptions until Ref is controlled.
  47             Ref  : constant Sequence_Ptr := Constructor (Last);
  48          begin
  49             if Args (Args'First).Kind = Kind_List then
  50                for I in 1 .. Args'Length - 1 loop
  51                   Ref.all.Data (I) := Args (Args'Last - I + 1);
  52                end loop;
  53                Ref.all.Data (Args'Length .. Last) := Data;
  54                return (Kind_List, Ref);
  55             else
  56                Ref.all.Data := Data & Args (Args'First + 1 .. Args'Last);
  57                return (Kind_Vector, Ref);
  58             end if;
  59          end;
  60       when others =>
  61          Err.Raise_With ("parameter 1 must be a sequence");
  62       end case;
  63    end Conj;
  64
  65    function Cons (Args : in T_Array) return T is
  66    begin
  67       Err.Check (Args'Length = 2
  68                    and then Args (Args'Last).Kind in Kind_Sequence,
  69                  "expected a value then a sequence");
  70       declare
  71          Head : T renames Args (Args'First);
  72          Tail : T_Array renames Args (Args'Last).Sequence.all.Data;
  73          Ref  : constant Sequence_Ptr := Constructor (1 + Tail'Length);
  74       begin
  75          Ref.all.Data := Head & Tail;
  76          return (Kind_List, Ref);
  77       end;
  78    end Cons;
  79
  80    function Constructor (Length : in Natural) return Sequence_Ptr is
  81       Ref : constant Sequence_Ptr := new Instance (Length);
  82    begin
  83       Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
  84       return Ref;
  85    end Constructor;
  86
  87    function Count (Args : in T_Array) return T is
  88    begin
  89       Err.Check (Args'Length = 1, "expected 1 parameter");
  90       case Args (Args'First).Kind is
  91       when Kind_Nil =>
  92          return (Kind_Number, 0);
  93       when Kind_Sequence =>
  94          return (Kind_Number, Args (Args'First).Sequence.all.Data'Length);
  95       when others =>
  96          Err.Raise_With ("parameter must be nil or a sequence");
  97       end case;
  98    end Count;
  99
 100    function First (Args : in T_Array) return T is
 101    begin
 102       Err.Check (Args'Length = 1, "expected 1 parameter");
 103       case Args (Args'First).Kind is
 104       when Kind_Nil =>
 105          return Nil;
 106       when Kind_Sequence =>
 107          declare
 108             Data : T_Array renames Args (Args'First).Sequence.all.Data;
 109          begin
 110             if Data'Length = 0 then
 111                return Nil;
 112             else
 113                return Data (Data'First);
 114             end if;
 115          end;
 116       when others =>
 117          Err.Raise_With ("parameter must be nil or a sequence");
 118       end case;
 119    end First;
 120
 121    function Is_Empty (Args : in T_Array) return T is
 122    begin
 123       Err.Check (Args'Length = 1
 124                    and then Args (Args'First).Kind in Kind_Sequence,
 125                  "expected a sequence");
 126       return (Kind_Boolean, Args (Args'First).Sequence.all.Data'Length = 0);
 127    end Is_Empty;
 128
 129    procedure Keep_References (Object : in out Instance) is
 130    begin
 131       Keep (Object.Meta);
 132       for M of Object.Data loop
 133          Keep (M);
 134       end loop;
 135    end Keep_References;
 136
 137    function List (Args : in T_Array) return T
 138    is
 139       Ref : constant Sequence_Ptr := Constructor (Args'Length);
 140    begin
 141       Ref.all.Data := Args;
 142       return (Kind_List, Ref);
 143    end List;
 144
 145    function Map (Args : in T_Array) return T is
 146    begin
 147       Err.Check (Args'Length = 2
 148                    and then Args (Args'Last).Kind in Kind_Sequence,
 149                  "expected a function then a sequence");
 150       declare
 151          F   : T renames Args (Args'First);
 152          Src : T_Array renames Args (Args'Last).Sequence.all.Data;
 153          Ref : constant Sequence_Ptr := Constructor (Src'Length);
 154       begin
 155          case F.Kind is
 156             when Kind_Builtin =>
 157                for I in Src'Range loop
 158                   Ref.all.Data (I) := F.Builtin.all (Src (I .. I));
 159                end loop;
 160             when Kind_Builtin_With_Meta =>
 161                for I in Src'Range loop
 162                   Ref.all.Data (I)
 163                     := F.Builtin_With_Meta.all.Builtin.all (Src (I .. I));
 164                end loop;
 165             when Kind_Fn =>
 166                for I in Src'Range loop
 167                   Ref.all.Data (I) := F.Fn.all.Apply (Src (I .. I));
 168                end loop;
 169             when others =>
 170                Err.Raise_With ("parameter 1 must be a function");
 171          end case;
 172          return (Kind_List, Ref);
 173       end;
 174    end Map;
 175
 176    function Nth (Args : in T_Array) return T is
 177    begin
 178       Err.Check (Args'Length = 2
 179                    and then Args (Args'First).Kind in Kind_Sequence
 180                    and then Args (Args'Last).Kind = Kind_Number,
 181                  "expected a sequence then a number");
 182       declare
 183          L : T_Array renames Args (Args'First).Sequence.all.Data;
 184          I : constant Integer := Args (Args'Last).Number + 1;
 185       begin
 186          Err.Check (I in L'Range, "index out of bounds");
 187          return L (I);
 188       end;
 189    end Nth;
 190
 191    function Rest (Args : in T_Array) return T is
 192    begin
 193       Err.Check (Args'Length = 1, "expected 1 parameter");
 194       case Args (Args'First).Kind is
 195       when Kind_Nil =>
 196          return (Kind_List, Constructor (0));
 197       when Kind_Sequence =>
 198          declare
 199             A1  : T_Array renames Args (Args'First).Sequence.all.Data;
 200             Ref : constant Sequence_Ptr
 201               := Constructor (Integer'Max (0, A1'Length - 1));
 202          begin
 203             Ref.all.Data := A1 (A1'First + 1 .. A1'Last);
 204             return (Kind_List, Ref);
 205          end;
 206       when others =>
 207          Err.Raise_With ("parameter must be nil or a sequence");
 208       end case;
 209    end Rest;
 210
 211    function Vector (Args : in T_Array) return T
 212    is
 213       Ref : constant Sequence_Ptr := Constructor (Args'Length);
 214    begin
 215       Ref.all.Data := Args;
 216       return (Kind_Vector, Ref);
 217    end Vector;
 218
 219 end Types.Sequences;