Test that macros use closures

[jackhill/mal.git] / ada.2 / types-atoms.adb

with Err;
with Types.Builtins;
with Types.Fns;

package body Types.Atoms is

   function Atom (Args : in T_Array) return T is
   begin
      Err.Check (Args'Length = 1, "expected 1 parameter");
      declare
         Ref : constant Atom_Ptr := new Instance;
      begin
         Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
         Ref.all.Data := Args (Args'First);
         return (Kind_Atom, Ref);
      end;
   end Atom;

   function Deref (Args : in T_Array) return T is
   begin
      Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_Atom,
                 "expected an atom");
      return Args (Args'First).Atom.all.Data;
   end Deref;

   function Deref (Item : in Instance) return T
   is (Item.Data);

   procedure Keep_References (Object : in out Instance) is
   begin
      Keep (Object.Data);
   end Keep_References;

   function Reset (Args : in T_Array) return T is
   begin
      Err.Check (Args'Length = 2 and then Args (Args'First).Kind = Kind_Atom,
                 "expected an atom then a value");
      Args (Args'First).Atom.all.Data := Args (Args'Last);
      return Args (Args'Last);
   end Reset;

   function Swap (Args : in T_Array) return T is
   begin
      Err.Check (2 <= Args'Length and then Args (Args'First).Kind = Kind_Atom,
                 "expected an atom, optional arguments then a function");
      declare
         X : T renames Args (Args'First).Atom.all.Data;
         F : T renames Args (Args'First + 1);
         A : constant T_Array := X & Args (Args'First + 2 .. Args'Last);
      begin
         case F.Kind is
            when Kind_Builtin =>
               X := F.Builtin.all (A);
            when Kind_Builtin_With_Meta =>
               X := F.Builtin_With_Meta.all.Builtin.all (A);
            when Kind_Fn =>
               X := F.Fn.all.Apply (A);
            when others =>
               Err.Raise_With ("parameter 2 must be a function");
         end case;
         return X;
      end;
   end Swap;

end Types.Atoms;