diff --git a/ada.2/Makefile b/ada.2/Makefile index 6fa626ce..2b17dda6 100644 --- a/ada.2/Makefile +++ b/ada.2/Makefile @@ -45,7 +45,6 @@ TYPES := $(call sources,\ types-atoms \ types-builtins \ types-fns \ - types-macros \ types-maps \ types-sequences \ types-strings \ diff --git a/ada.2/core.adb b/ada.2/core.adb index d1539b42..a9814c7d 100644 --- a/ada.2/core.adb +++ b/ada.2/core.adb @@ -178,8 +178,10 @@ package body Core is return A1.Builtin_With_Meta.all.Meta; when Kind_Builtin => return Types.Nil; + when Kind_Atom => + return A1.Atom.all.Meta; when others => - Err.Raise_With ("expected a function, map or sequence"); + Err.Raise_With ("expected an atom, function, map or sequence"); end case; end; end Meta; @@ -445,8 +447,10 @@ package body Core is when Kind_Map => return A1.Map.all.With_Meta (A2); when Kind_Fn => - return Types.Fns.New_Function (A1.Fn.all.Params, A1.Fn.all.Ast, - A1.Fn.all.Env, A2); + return (Kind_Fn, Types.Fns.New_Function + (A1.Fn.all.Params, A1.Fn.all.Ast, A1.Fn.all.Env, A2)); + when Kind_Atom => + return A1.Atom.all.With_Meta (A2); when others => Err.Raise_With ("parameter 1 must be a function, map or sequence"); diff --git a/ada.2/printer.adb b/ada.2/printer.adb index 48a708a9..0891cd74 100644 --- a/ada.2/printer.adb +++ b/ada.2/printer.adb @@ -2,7 +2,6 @@ with Ada.Characters.Latin_1; with Types.Atoms; with Types.Fns; -with Types.Macros; with Types.Maps; pragma Warnings (Off, "unit ""Types.Sequences"" is not referenced"); with Types.Sequences; @@ -79,9 +78,9 @@ package body Printer is Append (Buffer, '>'); when Kind_Macro => Append (Buffer, "# "); - Print_Form (Form_Ast.Macro.all.Ast); + Print_Form (Form_Ast.Fn.all.Ast); Append (Buffer, '>'); when Kind_Atom => Append (Buffer, "(atom "); diff --git a/ada.2/step4_if_fn_do.adb b/ada.2/step4_if_fn_do.adb index 08ab35b8..687e1c2e 100644 --- a/ada.2/step4_if_fn_do.adb +++ b/ada.2/step4_if_fn_do.adb @@ -135,10 +135,10 @@ procedure Step4_If_Fn_Do is begin Err.Check (Params.Kind in Types.Kind_Sequence, "first argument of fn* must be a sequence"); - return Types.Fns.New_Function + return (Kind_Fn, Types.Fns.New_Function (Params => Params.Sequence, Ast => Ast.Sequence.all.Data (3), - Env => Env); + Env => Env)); end; else First := Eval (First, Env); diff --git a/ada.2/step5_tco.adb b/ada.2/step5_tco.adb index d48afa38..b69dbe38 100644 --- a/ada.2/step5_tco.adb +++ b/ada.2/step5_tco.adb @@ -141,6 +141,7 @@ procedure Step5_Tco is for I in 2 .. Ast.Sequence.all.Length - 1 loop Result := Eval (Ast.Sequence.all.Data (I), Env); end loop; + pragma Unreferenced (Result); end; Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); goto Restart; @@ -152,10 +153,10 @@ procedure Step5_Tco is Err.Check (Params.Kind in Types.Kind_Sequence, "first argument of fn* must be a sequence"); Env_Reusable := False; - return Types.Fns.New_Function + return (Kind_Fn, Types.Fns.New_Function (Params => Params.Sequence, Ast => Ast.Sequence.all.Data (3), - Env => Env); + Env => Env)); end; else -- Equivalent to First := Eval (First, Env) diff --git a/ada.2/step6_file.adb b/ada.2/step6_file.adb index 8195d6fc..d10488af 100644 --- a/ada.2/step6_file.adb +++ b/ada.2/step6_file.adb @@ -145,6 +145,7 @@ procedure Step6_File is for I in 2 .. Ast.Sequence.all.Length - 1 loop Result := Eval (Ast.Sequence.all.Data (I), Env); end loop; + pragma Unreferenced (Result); end; Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); goto Restart; @@ -156,10 +157,10 @@ procedure Step6_File is Err.Check (Params.Kind in Types.Kind_Sequence, "first argument of fn* must be a sequence"); Env_Reusable := False; - return Types.Fns.New_Function + return (Kind_Fn, Types.Fns.New_Function (Params => Params.Sequence, Ast => Ast.Sequence.all.Data (3), - Env => Env); + Env => Env)); end; else -- Equivalent to First := Eval (First, Env) diff --git a/ada.2/step7_quote.adb b/ada.2/step7_quote.adb index 70bfb925..d3f6d5c5 100644 --- a/ada.2/step7_quote.adb +++ b/ada.2/step7_quote.adb @@ -157,6 +157,7 @@ procedure Step7_Quote is for I in 2 .. Ast.Sequence.all.Length - 1 loop Result := Eval (Ast.Sequence.all.Data (I), Env); end loop; + pragma Unreferenced (Result); end; Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); goto Restart; @@ -168,10 +169,10 @@ procedure Step7_Quote is Err.Check (Params.Kind in Types.Kind_Sequence, "first argument of fn* must be a sequence"); Env_Reusable := False; - return Types.Fns.New_Function + return (Kind_Fn, Types.Fns.New_Function (Params => Params.Sequence, Ast => Ast.Sequence.all.Data (3), - Env => Env); + Env => Env)); end; elsif First.Str.all = "quasiquote" then Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); diff --git a/ada.2/step8_macros.adb b/ada.2/step8_macros.adb index f67e0865..3786b8ed 100644 --- a/ada.2/step8_macros.adb +++ b/ada.2/step8_macros.adb @@ -11,7 +11,6 @@ with Printer; with Reader; with Readline; with Types.Fns; -with Types.Macros; with Types.Maps; with Types.Sequences; with Types.Strings; @@ -159,7 +158,10 @@ procedure Step8_Macros is Val : Types.T; begin Err.Check (Fun.Kind = Kind_Fn, "expected a function"); - Val := Types.Macros.New_Macro (Fun.Fn.all); + Val := (Kind_Macro, Types.Fns.New_Function + (Params => Fun.Fn.all.Params, + Ast => Fun.Fn.all.Ast, + Env => Fun.Fn.all.Env)); Env.all.Set (Key, Val); -- Check key kind. return Val; end; @@ -171,6 +173,7 @@ procedure Step8_Macros is for I in 2 .. Ast.Sequence.all.Length - 1 loop Result := Eval (Ast.Sequence.all.Data (I), Env); end loop; + pragma Unreferenced (Result); end; Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); goto Restart; @@ -182,10 +185,10 @@ procedure Step8_Macros is Err.Check (Params.Kind in Types.Kind_Sequence, "first argument of fn* must be a sequence"); Env_Reusable := False; - return Types.Fns.New_Function + return (Kind_Fn, Types.Fns.New_Function (Params => Params.Sequence, Ast => Ast.Sequence.all.Data (3), - Env => Env); + Env => Env)); end; elsif First.Str.all = "macroexpand" then Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); @@ -220,27 +223,20 @@ procedure Step8_Macros is if Macroexpanding then -- Evaluate the macro with tail call optimization. if not Env_Reusable then - Env := Envs.New_Env (Outer => Env); + Env := Envs.New_Env (Outer => First.Fn.all.Env); Env_Reusable := True; end if; Env.all.Set_Binds - (Binds => First.Macro.all.Params.all.Data, + (Binds => First.Fn.all.Params.all.Data, Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); - Ast := First.Macro.all.Ast; + Ast := First.Fn.all.Ast; goto Restart; else -- Evaluate the macro normally. - declare - New_Env : constant Envs.Ptr := Envs.New_Env (Outer => Env); - begin - New_Env.all.Set_Binds - (Binds => First.Macro.all.Params.all.Data, - Exprs => Ast.Sequence.all.Data - (2 .. Ast.Sequence.all.Length)); - Ast := Eval (First.Macro.all.Ast, New_Env); - -- Then evaluate the result with TCO. - goto Restart; - end; + Ast := First.Fn.all.Apply + (Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); + -- Then evaluate the result with TCO. + goto Restart; end if; when Types.Kind_Function => null; diff --git a/ada.2/step9_try.adb b/ada.2/step9_try.adb index fe8d26db..bc26dd0f 100644 --- a/ada.2/step9_try.adb +++ b/ada.2/step9_try.adb @@ -11,7 +11,6 @@ with Printer; with Reader; with Readline; with Types.Fns; -with Types.Macros; with Types.Maps; with Types.Sequences; with Types.Strings; @@ -159,7 +158,10 @@ procedure Step9_Try is Val : Types.T; begin Err.Check (Fun.Kind = Kind_Fn, "expected a function"); - Val := Types.Macros.New_Macro (Fun.Fn.all); + Val := (Kind_Macro, Types.Fns.New_Function + (Params => Fun.Fn.all.Params, + Ast => Fun.Fn.all.Ast, + Env => Fun.Fn.all.Env)); Env.all.Set (Key, Val); -- Check key kind. return Val; end; @@ -171,6 +173,7 @@ procedure Step9_Try is for I in 2 .. Ast.Sequence.all.Length - 1 loop Result := Eval (Ast.Sequence.all.Data (I), Env); end loop; + pragma Unreferenced (Result); end; Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); goto Restart; @@ -182,10 +185,10 @@ procedure Step9_Try is Err.Check (Params.Kind in Types.Kind_Sequence, "first argument of fn* must be a sequence"); Env_Reusable := False; - return Types.Fns.New_Function + return (Kind_Fn, Types.Fns.New_Function (Params => Params.Sequence, Ast => Ast.Sequence.all.Data (3), - Env => Env); + Env => Env)); end; elsif First.Str.all = "macroexpand" then Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); @@ -250,27 +253,20 @@ procedure Step9_Try is if Macroexpanding then -- Evaluate the macro with tail call optimization. if not Env_Reusable then - Env := Envs.New_Env (Outer => Env); + Env := Envs.New_Env (Outer => First.Fn.all.Env); Env_Reusable := True; end if; Env.all.Set_Binds - (Binds => First.Macro.all.Params.all.Data, + (Binds => First.Fn.all.Params.all.Data, Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); - Ast := First.Macro.all.Ast; + Ast := First.Fn.all.Ast; goto Restart; else -- Evaluate the macro normally. - declare - New_Env : constant Envs.Ptr := Envs.New_Env (Outer => Env); - begin - New_Env.all.Set_Binds - (Binds => First.Macro.all.Params.all.Data, - Exprs => Ast.Sequence.all.Data - (2 .. Ast.Sequence.all.Length)); - Ast := Eval (First.Macro.all.Ast, New_Env); - -- Then evaluate the result with TCO. - goto Restart; - end; + Ast := First.Fn.all.Apply + (Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); + -- Then evaluate the result with TCO. + goto Restart; end if; when Types.Kind_Function => null; diff --git a/ada.2/stepa_mal.adb b/ada.2/stepa_mal.adb index 2217f7b8..0c665904 100644 --- a/ada.2/stepa_mal.adb +++ b/ada.2/stepa_mal.adb @@ -12,7 +12,6 @@ with Reader; with Readline; with Types.Builtins; with Types.Fns; -with Types.Macros; with Types.Maps; with Types.Sequences; with Types.Strings; @@ -160,7 +159,10 @@ procedure StepA_Mal is Val : Types.T; begin Err.Check (Fun.Kind = Kind_Fn, "expected a function"); - Val := Types.Macros.New_Macro (Fun.Fn.all); + Val := (Kind_Macro, Types.Fns.New_Function + (Params => Fun.Fn.all.Params, + Ast => Fun.Fn.all.Ast, + Env => Fun.Fn.all.Env)); Env.all.Set (Key, Val); -- Check key kind. return Val; end; @@ -172,6 +174,7 @@ procedure StepA_Mal is for I in 2 .. Ast.Sequence.all.Length - 1 loop Result := Eval (Ast.Sequence.all.Data (I), Env); end loop; + pragma Unreferenced (Result); end; Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); goto Restart; @@ -183,10 +186,10 @@ procedure StepA_Mal is Err.Check (Params.Kind in Types.Kind_Sequence, "first argument of fn* must be a sequence"); Env_Reusable := False; - return Types.Fns.New_Function + return (Kind_Fn, Types.Fns.New_Function (Params => Params.Sequence, Ast => Ast.Sequence.all.Data (3), - Env => Env); + Env => Env)); end; elsif First.Str.all = "macroexpand" then Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); @@ -251,27 +254,20 @@ procedure StepA_Mal is if Macroexpanding then -- Evaluate the macro with tail call optimization. if not Env_Reusable then - Env := Envs.New_Env (Outer => Env); + Env := Envs.New_Env (Outer => First.Fn.all.Env); Env_Reusable := True; end if; Env.all.Set_Binds - (Binds => First.Macro.all.Params.all.Data, + (Binds => First.Fn.all.Params.all.Data, Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); - Ast := First.Macro.all.Ast; + Ast := First.Fn.all.Ast; goto Restart; else -- Evaluate the macro normally. - declare - New_Env : constant Envs.Ptr := Envs.New_Env (Outer => Env); - begin - New_Env.all.Set_Binds - (Binds => First.Macro.all.Params.all.Data, - Exprs => Ast.Sequence.all.Data - (2 .. Ast.Sequence.all.Length)); - Ast := Eval (First.Macro.all.Ast, New_Env); - -- Then evaluate the result with TCO. - goto Restart; - end; + Ast := First.Fn.all.Apply + (Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); + -- Then evaluate the result with TCO. + goto Restart; end if; when Types.Kind_Function => null; diff --git a/ada.2/types-atoms.adb b/ada.2/types-atoms.adb index 766a1f18..fd3d4b30 100644 --- a/ada.2/types-atoms.adb +++ b/ada.2/types-atoms.adb @@ -29,8 +29,12 @@ package body Types.Atoms is procedure Keep_References (Object : in out Instance) is begin Keep (Object.Data); + Keep (Object.Meta); end Keep_References; + function Meta (Item : in Instance) return T + is (Item.F_Meta); + function Reset (Args : in T_Array) return T is begin Err.Check (Args'Length = 2 and then Args (Args'First).Kind = Kind_Atom, @@ -62,4 +66,14 @@ package body Types.Atoms is end; end Swap; + function With_Meta (Item : in Instance; + Metadata : in T) return T is + Ref : constant Atom_Ptr := new Instance; + begin + Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); + Ref.all.Data := Item.Data; + Ref.all.F_Meta := Metadata; + return (Kind_Atom, Ref); + end With_Meta; + end Types.Atoms; diff --git a/ada.2/types-atoms.ads b/ada.2/types-atoms.ads index 8764ad44..86571f8e 100644 --- a/ada.2/types-atoms.ads +++ b/ada.2/types-atoms.ads @@ -13,10 +13,15 @@ package Types.Atoms is -- Helper for print. function Deref (Item : in Instance) return T with Inline; + function With_Meta (Item : in Instance; + Metadata : in T) return T; + function Meta (Item : in Instance) return T; + private type Instance is new Garbage_Collected.Instance with record Data : T; + F_Meta : T; end record; overriding procedure Keep_References (Object : in out Instance) with Inline; diff --git a/ada.2/types-fns.adb b/ada.2/types-fns.adb index edffd320..6deb6e06 100644 --- a/ada.2/types-fns.adb +++ b/ada.2/types-fns.adb @@ -36,7 +36,7 @@ package body Types.Fns is function New_Function (Params : in Sequence_Ptr; Ast : in T; Env : in Envs.Ptr; - Metadata : in T := Nil) return T + Metadata : in T := Nil) return Fn_Ptr is -- Env and Params are not null and require an immediate -- initialization. @@ -50,7 +50,7 @@ package body Types.Fns is Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); Err.Check ((for all P of Params.all.Data => P.Kind = Kind_Symbol), "formal parameters must be symbols"); - return (Kind_Fn, Ref); + return Ref; end New_Function; function Params (Item : in Instance) return Sequence_Ptr diff --git a/ada.2/types-fns.ads b/ada.2/types-fns.ads index 77f9b8a4..7a0b8f56 100644 --- a/ada.2/types-fns.ads +++ b/ada.2/types-fns.ads @@ -13,7 +13,7 @@ package Types.Fns is function New_Function (Params : in Sequence_Ptr; Ast : in T; Env : in Envs.Ptr; - Metadata : in T := Nil) return T + Metadata : in T := Nil) return Fn_Ptr with Inline; -- Raise an exception if Params contains something else than symbols. diff --git a/ada.2/types-macros.adb b/ada.2/types-macros.adb deleted file mode 100644 index 6e3ddd08..00000000 --- a/ada.2/types-macros.adb +++ /dev/null @@ -1,28 +0,0 @@ -pragma Warnings (Off, "unit ""Types.Sequences"" is not referenced"); -with Types.Sequences; -pragma Warnings (On, "unit ""Types.Sequences"" is not referenced"); - -package body Types.Macros is - - function Ast (Item : in Instance) return T - is (Item.F_Ast); - - procedure Keep_References (Object : in out Instance) is - begin - Keep (Object.F_Ast); - Object.F_Params.all.Keep; - end Keep_References; - - function New_Macro (Func : in Fns.Instance) return T is - -- Params is not null and requires an immediate initialization. - Ref : constant Macro_Ptr := new Instance' - (Garbage_Collected.Instance with Func.Ast, Func.Params); - begin - Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); - return (Kind_Macro, Ref); - end New_Macro; - - function Params (Item : in Instance) return Sequence_Ptr - is (Item.F_Params); - -end Types.Macros; diff --git a/ada.2/types-macros.ads b/ada.2/types-macros.ads deleted file mode 100644 index be3a3763..00000000 --- a/ada.2/types-macros.ads +++ /dev/null @@ -1,22 +0,0 @@ -with Garbage_Collected; -with Types.Fns; - -package Types.Macros is - - type Instance (<>) is abstract new Garbage_Collected.Instance with private; - - function New_Macro (Func : in Fns.Instance) return T with Inline; - - function Ast (Item : in Instance) return T with Inline; - function Params (Item : in Instance) return Sequence_Ptr with Inline; - -private - - type Instance is new Garbage_Collected.Instance with record - F_Ast : T; - F_Params : Sequence_Ptr; - end record; - - overriding procedure Keep_References (Object : in out Instance) with Inline; - -end Types.Macros; diff --git a/ada.2/types.adb b/ada.2/types.adb index 96ca3ef4..6b0ebf0a 100644 --- a/ada.2/types.adb +++ b/ada.2/types.adb @@ -2,7 +2,6 @@ pragma Warnings (Off, "no entities of ""Types.*"" are referenced"); with Types.Atoms; with Types.Builtins; with Types.Fns; -with Types.Macros; with Types.Maps; with Types.Sequences; pragma Warnings (On, "no entities of ""Types.*"" are referenced"); @@ -51,10 +50,8 @@ package body Types is Object.Map.all.Keep; when Kind_Builtin_With_Meta => Object.Builtin_With_Meta.all.Keep; - when Kind_Fn => + when Kind_Fn | Kind_Macro => Object.Fn.all.Keep; - when Kind_Macro => - Object.Macro.all.Keep; end case; end Keep; diff --git a/ada.2/types.ads b/ada.2/types.ads index 6dd0b71d..011288b6 100644 --- a/ada.2/types.ads +++ b/ada.2/types.ads @@ -1,7 +1,6 @@ limited with Types.Atoms; limited with Types.Builtins; limited with Types.Fns; -limited with Types.Macros; limited with Types.Maps; limited with Types.Sequences; limited with Types.Strings; @@ -49,7 +48,6 @@ package Types is type Builtin_Ptr is not null access function (Args : in T_Array) return T; type Builtin_With_Meta_Ptr is not null access Builtins.Instance; type Fn_Ptr is not null access Fns.Instance; - type Macro_Ptr is not null access Macros.Instance; type Map_Ptr is not null access Maps.Instance; type Sequence_Ptr is not null access Sequences.Instance; type String_Ptr is not null access Strings.Instance; @@ -74,10 +72,8 @@ package Types is Builtin : Builtin_Ptr; when Kind_Builtin_With_Meta => Builtin_With_Meta : Builtin_With_Meta_Ptr; - when Kind_Fn => + when Kind_Fn | Kind_Macro => Fn : Fn_Ptr; - when Kind_Macro => - Macro : Macro_Ptr; end case; end record; diff --git a/tests/step8_macros.mal b/tests/step8_macros.mal index 8cce8dc9..59868928 100644 --- a/tests/step8_macros.mal +++ b/tests/step8_macros.mal @@ -148,3 +148,13 @@ x (let* [x (or nil "yes")] x) ;=>"yes" + +;>>> soft=True + +;; Test that macros use closures +(def! x 2) +(defmacro! a (fn* [] x)) +(a) +;=>2 +(let* (x 3) (a)) +;=>2