impls/ada.2/types-atoms.adb

   1 with Err;
   2 with Types.Builtins;
   3 with Types.Fns;
   4
   5 package body Types.Atoms is
   6
   7    function Atom (Args : in T_Array) return T is
   8    begin
   9       Err.Check (Args'Length = 1, "expected 1 parameter");
  10       declare
  11          Ref : constant Atom_Ptr := new Instance;
  12       begin
  13          Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
  14          Ref.all.Data := Args (Args'First);
  15          return (Kind_Atom, Ref);
  16       end;
  17    end Atom;
  18
  19    function Deref (Args : in T_Array) return T is
  20    begin
  21       Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_Atom,
  22                  "expected an atom");
  23       return Args (Args'First).Atom.all.Data;
  24    end Deref;
  25
  26    function Deref (Item : in Instance) return T
  27    is (Item.Data);
  28
  29    procedure Keep_References (Object : in out Instance) is
  30    begin
  31       Keep (Object.Data);
  32       Keep (Object.Meta);
  33    end Keep_References;
  34
  35    function Meta (Item : in Instance) return T
  36    is (Item.F_Meta);
  37
  38    function Reset (Args : in T_Array) return T is
  39    begin
  40       Err.Check (Args'Length = 2 and then Args (Args'First).Kind = Kind_Atom,
  41                  "expected an atom then a value");
  42       Args (Args'First).Atom.all.Data := Args (Args'Last);
  43       return Args (Args'Last);
  44    end Reset;
  45
  46    function Swap (Args : in T_Array) return T is
  47    begin
  48       Err.Check (2 <= Args'Length and then Args (Args'First).Kind = Kind_Atom,
  49                  "expected an atom, optional arguments then a function");
  50       declare
  51          X : T renames Args (Args'First).Atom.all.Data;
  52          F : T renames Args (Args'First + 1);
  53          A : constant T_Array := X & Args (Args'First + 2 .. Args'Last);
  54       begin
  55          case F.Kind is
  56             when Kind_Builtin =>
  57                X := F.Builtin.all (A);
  58             when Kind_Builtin_With_Meta =>
  59                X := F.Builtin_With_Meta.all.Builtin.all (A);
  60             when Kind_Fn =>
  61                X := F.Fn.all.Apply (A);
  62             when others =>
  63                Err.Raise_With ("parameter 2 must be a function");
  64          end case;
  65          return X;
  66       end;
  67    end Swap;
  68
  69    function With_Meta (Item     : in Instance;
  70                        Metadata : in T) return T is
  71       Ref : constant Atom_Ptr := new Instance;
  72    begin
  73       Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
  74       Ref.all.Data := Item.Data;
  75       Ref.all.F_Meta := Metadata;
  76       return (Kind_Atom, Ref);
  77    end With_Meta;
  78
  79 end Types.Atoms;