diff --git a/ada.2/Makefile b/ada.2/Makefile index 012ffdda..3cc1a3e8 100644 --- a/ada.2/Makefile +++ b/ada.2/Makefile @@ -37,6 +37,7 @@ TYPES := \ envs.ads envs.adb \ err.ads err.adb \ eval_cb.ads \ + garbage_collected.ads garbage_collected.adb \ printer.ads printer.adb \ reader.ads reader.adb \ readline.ads \ diff --git a/ada.2/README b/ada.2/README index 1d72e784..f05e7a70 100644 --- a/ada.2/README +++ b/ada.2/README @@ -14,19 +14,19 @@ but also two crucial performance improvements: * Lists are implemented as C-style arrays, and most of them can be allocated on the stack. -Once each component has an explicit interface, various optimizations -have been added: unique allocation of symbols, stack-style allocation -of environments in the current execution path, reuse of allocated -memory when the reference count reaches 1... +Another difference is that a minimal form of garbage collecting is +implemented, removing objects not referenced from the main +environment. Reference counting is convenient for symbols or strings, +but never deallocates cyclic structures. The implementation collects +garbage after each Read-Eval-Print cycle. It would be much more +difficult to collect garbage inside scripts. If this is ever done, it +would be better to reimplement load-file in Ada and run a cycle after +each root evaluation. The eventual performances compete with C-style languages, allthough all user input is checked (implicit language-defined checks like array bounds and discriminant consistency are only enabled during tests). -There are also similarities with the first implementation. For -example, both rely on user-defined finalization to count references in -recursive structures instead of a posteriori garbage collection. - Notes for contributors that do not fit in a specific package. -- @@ -35,24 +35,29 @@ Notes for contributors that do not fit in a specific package. ensuring a valid value during elaboration. Note that generic packages cannot export access values. -* All wrapped pointers are non null, new variables must be assigned +* Symbol pointers are non null, new variables must be assigned immediately. This is usually enforced by a hidden discriminant, but here we want the type to become a field inside Types.Mal.T. So the check happens at run time with a private invariant. -* The finalize procedure may be called twice, so it does nothing when + The finalize procedure may be called twice, so it does nothing when the reference count is zero, meaning that we are reaching Finalize recursively. -* In implementations, a consistent object (that will be deallocated - automatically) must be built before any exception is raised by user - code (for example the 'map' built-in function may run user code). +* In implementations with reference counting, a consistent object + (that will be deallocated automatically) must be built before any + exception is raised by user code (for example the 'map' built-in + function may run user code). Garbage collection simplifies a lot + this kind of situations. * Each module encapsulating dynamic allocation counts allocations and deallocations. With debugging options, a failure is reported if - too many deallocation happen (via a numeric range check) - all storage is not freed (via a dedicated call from the step file) + The main program only checks that the garbage collector removes all + allocations at the end of execution. + Debugging -- @@ -61,7 +66,5 @@ TCO cycles). This has become possible in step9, but has been backported to former steps as this is really handy for debugging. Some environment variables increase verbosity. -# dbg_reader= ./stepAmal trace reader recursion -# dbgeval= ./stepAmal eval recursion (or TCO) -# dbgenv0= ./stepAmal eval recursion and environments contents -# dbgenv1= ./stepAmal eval recursion and environment internals +# dbgread= ./stepAmal trace reader recursion +# dbgeval= ./stepAmal trace eval recursion (including TCO) diff --git a/ada.2/core.adb b/ada.2/core.adb index 2f580f0d..1e53c503 100644 --- a/ada.2/core.adb +++ b/ada.2/core.adb @@ -3,11 +3,10 @@ with Ada.Characters.Latin_1; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; -with Envs; with Err; -with Eval_Cb; with Types.Atoms; with Types.Builtins; +with Types.Fns; with Types.Mal; with Types.Maps; with Types.Sequences; @@ -64,7 +63,6 @@ package body Core is function Apply (Args : in Mal.T_Array) return Mal.T; function Division is new Generic_Mal_Operator ("/"); function Equals (Args : in Mal.T_Array) return Mal.T; - function Eval (Args : in Mal.T_Array) return Mal.T; function Greater_Equal is new Generic_Comparison (">="); function Greater_Than is new Generic_Comparison (">"); function Is_Atom is new Generic_Kind_Test (Kind_Atom); @@ -108,19 +106,19 @@ package body Core is Err.Check (Args (Args'Last).Kind in Kind_Sequence, "last parameter must be a sequence"); declare - use type Sequences.Ptr; + use type Sequences.Instance; F : Mal.T renames Args (Args'First); A : constant Mal.T_Array := Args (Args'First + 1 .. Args'Last - 1) - & Args (Args'Last).Sequence; + & Args (Args'Last).Sequence.all; begin case F.Kind is when Kind_Builtin => return F.Builtin.all (A); when Kind_Builtin_With_Meta => - return F.Builtin_With_Meta.Builtin.all (A); + return F.Builtin_With_Meta.all.Builtin.all (A); when Kind_Fn => - return F.Fn.Apply (A); + return F.Fn.all.Apply (A); when others => Err.Raise_With ("parameter 1 must be a function"); end case; @@ -134,13 +132,6 @@ package body Core is return (Kind_Boolean, Args (Args'First) = Args (Args'Last)); end Equals; - function Eval (Args : in Mal.T_Array) return Mal.T is - begin - Err.Check (Args'Length = 1, "expected 1 parameter"); - return Eval_Cb.Cb.all (Ast => Args (Args'First), - Env => Envs.Repl); - end Eval; - function Is_False (Args : in Mal.T_Array) return Mal.T is begin Err.Check (Args'Length = 1, "expected 1 parameter"); @@ -188,13 +179,13 @@ package body Core is begin case A1.Kind is when Kind_Sequence => - return A1.Sequence.Meta; + return A1.Sequence.all.Meta; when Kind_Map => - return A1.Map.Meta; + return A1.Map.all.Meta; when Kind_Fn => - return A1.Fn.Meta; + return A1.Fn.all.Meta; when Kind_Builtin_With_Meta => - return A1.Builtin_With_Meta.Meta; + return A1.Builtin_With_Meta.all.Meta; when Kind_Builtin => return Mal.Nil; when others => @@ -203,14 +194,14 @@ package body Core is end; end Meta; - procedure NS_Add_To_Repl is + procedure NS_Add_To_Repl (Repl : in Envs.Ptr) is procedure P (S : in Symbols.Ptr; B : in Mal.Builtin_Ptr) with Inline; procedure P (S : in Symbols.Ptr; B : in Mal.Builtin_Ptr) is begin - Envs.Repl.Set (S, (Kind_Builtin, B)); + Repl.all.Set (S, (Kind_Builtin, B)); end P; begin P (Symbols.Constructor ("+"), Addition'Access); @@ -227,7 +218,6 @@ package body Core is P (Symbols.Constructor ("/"), Division'Access); P (Symbols.Constructor ("do"), Mal_Do'Access); P (Symbols.Constructor ("="), Equals'Access); - P (Symbols.Constructor ("eval"), Eval'Access); P (Symbols.Constructor ("first"), Sequences.First'Access); P (Symbols.Constructor ("get"), Maps.Get'Access); P (Symbols.Constructor (">="), Greater_Equal'Access); @@ -360,7 +350,7 @@ package body Core is end; end if; when Kind_Sequence => - if Args (Args'First).Sequence.Length = 0 then + if Args (Args'First).Sequence.all.Length = 0 then return Mal.Nil; else return (Kind_List, Args (Args'First).Sequence); @@ -427,17 +417,17 @@ package body Core is begin case A1.Kind is when Kind_Builtin_With_Meta => - return A1.Builtin_With_Meta.With_Meta (A2); + return Builtins.With_Meta (A1.Builtin_With_Meta.all, A2); when Kind_Builtin => return Builtins.With_Meta (A1.Builtin, A2); when Kind_List => - return (Kind_List, A1.Sequence.With_Meta (A2)); + return (Kind_List, Sequences.With_Meta (A1.Sequence.all, A2)); when Kind_Vector => - return (Kind_Vector, A1.Sequence.With_Meta (A2)); + return (Kind_Vector, Sequences.With_Meta (A1.Sequence.all, A2)); when Kind_Map => - return A1.Map.With_Meta (A2); + return Maps.With_Meta (A1.Map.all, A2); when Kind_Fn => - return A1.Fn.With_Meta (A2); + return Fns.With_Meta (A1.Fn.all, A2); when others => Err.Raise_With ("parameter 1 must be a function, map or sequence"); diff --git a/ada.2/core.ads b/ada.2/core.ads index faa8abb4..de6027e8 100644 --- a/ada.2/core.ads +++ b/ada.2/core.ads @@ -1,6 +1,8 @@ +with Envs; + package Core with Elaborate_Body is - procedure NS_Add_To_Repl; - -- Add built-in functions to Envs.Repl. + procedure NS_Add_To_Repl (Repl : in Envs.Ptr); + -- Add built-in functions. end Core; diff --git a/ada.2/envs.adb b/ada.2/envs.adb index 06b6dcf9..0575d87a 100644 --- a/ada.2/envs.adb +++ b/ada.2/envs.adb @@ -1,6 +1,4 @@ -with Ada.Containers.Hashed_Maps; with Ada.Text_IO.Unbounded_IO; -with Ada.Unchecked_Deallocation; with Err; with Printer; @@ -11,417 +9,93 @@ package body Envs is use Types; - -- The Eval built-in uses the REPL root environment (index 1), - -- all others parameters only repeat the top index. - - package HM is new Ada.Containers.Hashed_Maps - (Key_Type => Symbols.Ptr, - Element_Type => Mal.T, - Hash => Symbols.Hash, - Equivalent_Keys => Symbols."=", - "=" => Mal."="); - - type Stack_Record - (Outer_On_Stack : Boolean := True) is record - Data : HM.Map := HM.Empty_Map; - Refs : Natural := 1; - -- Only references via the Ptr type. - -- References from the stack or Alias are not counted here. - Alias : Heap_Access := null; - -- Used by the closures and heap records to refer to this stack - -- record, so that if it moves to the heap we only need to - -- update the alias. - case Outer_On_Stack is - when True => - Outer_Index : Stack_Index := 0; - when False => - Outer_Ref : Heap_Access := null; - end case; - end record - with Dynamic_Predicate => 0 < Refs - and (Alias = null or else Alias.all.Outer = null) - and (if Outer_On_Stack - then Outer_Index <= Top - else Outer_Ref /= null); - - -- It is forbidden to change the discriminant of an access type, - -- so we cannot use a discriminant here. - type Heap_Record is limited record - Refs : Natural := 1; - Data : HM.Map := HM.Empty_Map; - Index : Stack_Index; - Outer : Heap_Access := null; - end record - with Dynamic_Predicate => - (if Outer = null - then Index in 1 .. Top and Data.Is_Empty - else 0 < Refs); - -- Either an alias for a stack element or an actual environment. - - -- There could be one single type, but this would enlarge the - -- stack without simplifying the code, and prevent some more - -- static type checking. - - Stack : array (Stack_Index range 1 .. Stack_Index'Last) of Stack_Record; - -- The default value gives a consistent value to Stack (1), - -- compatible with the Repl constant. - - procedure Free is new Ada.Unchecked_Deallocation (Heap_Record, Heap_Access); - Allocations : Natural := 0; - - procedure Unreference (Reference : in out Heap_Access); - - procedure Set_Binds (M : in out HM.Map; - Binds : in Symbols.Symbol_Array; - Exprs : in Mal.T_Array); - ---------------------------------------------------------------------- - procedure Adjust (Object : in out Closure_Ptr) is - begin - if Object.Ref /= null then - Object.Ref.all.Refs := @ + 1; - end if; - end Adjust; - - procedure Clear_And_Check_Allocations is - begin - pragma Assert (Top = 1); - pragma Assert (Stack (1).Refs = 1); - Stack (1).Data.Clear; - if Stack (1).Alias /= null then - if Stack (1).Alias.all.Refs /= 0 then - Dump_Stack (Long => True); - end if; - pragma Assert (Stack (1).Alias.all.Refs = 0); - Allocations := Allocations - 1; - Free (Stack (1).Alias); - end if; - pragma Assert (Allocations = 0); - end Clear_And_Check_Allocations; - - function Copy_Pointer (Env : in Ptr) return Ptr is - pragma Assert (Env.Index in 1 | Top); - begin - Stack (Env.Index).Refs := @ + 1; - return (Ada.Finalization.Limited_Controlled with Env.Index); - end Copy_Pointer; - - procedure Dump_Stack (Long : in Boolean) is + procedure Dump_Stack (Env : in Instance) is use Ada.Text_IO; begin - for I in 1 .. Top loop - if Long then - Put ("Level"); - end if; - Put (I'Img); - if Long then + Put_Line ("environment:"); + for P in Env.Data.Iterate loop + -- Do not print builtins for repl. + if HM.Element (P).Kind /= Kind_Builtin or Env.Outer /= null then + Put (" "); + Put (HM.Key (P).To_String); + Put (':'); + Unbounded_IO.Put (Printer.Pr_Str (HM.Element (P))); New_Line; - Put_Line (" refs=" & Stack (I).Refs'Img); - if Stack (I).Alias = null then - Put_Line (" no alias"); - else - Put_Line (" an alias with" & Stack (I).Alias.all.Refs'Img - & " refs"); - end if; end if; - if Long then - Put (" outer="); - else - Put (" (->"); - end if; - if Stack (I).Outer_On_Stack then - Put (Stack (I).Outer_Index'Img); - elsif Stack (I).Outer_Ref.all.Outer = null then - if Long then - Put ("alias for "); - end if; - Put (Stack (I).Outer_Ref.all.Index'Img); - else - Put (" closure for ex " & Stack (I).Outer_Ref.all.Index'Img); - end if; - if Long then - New_Line; - else - Put ("):"); - end if; - for P in Stack (I).Data.Iterate loop - if HM.Element (P).Kind /= Kind_Builtin or 1 < I then - Put (" "); - Put (HM.Key (P).To_String); - Put (':'); - Unbounded_IO.Put (Printer.Pr_Str (HM.Element (P))); - if Long then - New_Line; - end if; - end if; - end loop; - New_Line; end loop; + if Env.Outer /= null then + Put ("outer is "); + Env.Outer.all.Dump_Stack; + end if; end Dump_Stack; - procedure Finalize (Object : in out Closure_Ptr) is - begin - Unreference (Object.Ref); - end Finalize; - - procedure Finalize (Object : in out Ptr) is - begin - if 0 < Object.Index then - if 0 < Stack (Object.Index).Refs then - Stack (Object.Index).Refs := @ - 1; - end if; - Object.Index := 0; - - -- If Index = Top and there are no more references. - loop - pragma Assert (0 < Top); - declare - R : Stack_Record renames Stack (Top); - begin - exit when 0 < R.Refs; - - if Top = 1 then - R.Data.Clear; - if R.Alias /= null then - pragma Assert (R.Alias.all.Outer = null); - pragma Assert (R.Alias.all.Refs = 0); - Allocations := Allocations - 1; - Free (R.Alias); - end if; - exit; - elsif R.Alias = null then - R.Data.Clear; - if not R.Outer_On_Stack then - Unreference (R.Outer_Ref); - end if; - elsif R.Alias.all.Refs = 0 then - pragma Assert (R.Alias.all.Outer = null); - Allocations := Allocations - 1; - Free (R.Alias); - R.Data.Clear; - if not R.Outer_On_Stack then - Unreference (R.Outer_Ref); - end if; - else - -- Detach this environment from the stack. - - -- The reference count is already correct. - - -- Copy the hashmap contents without reallocation.. - R.Alias.all.Data.Move (R.Data); - - -- The Index will not be used anymore. - - -- We need the parent to have an alias, in case it - -- must be detached later. - if R.Outer_On_Stack then - declare - O : Stack_Record renames Stack (R.Outer_Index); - begin - if O.Alias = null then - Allocations := Allocations + 1; - O.Alias := new Heap_Record'(Index => R.Outer_Index, - others => <>); - else - O.Alias.all.Refs := @ + 1; - end if; - R.Alias.all.Outer := O.Alias; - end; - else - R.Alias.all.Outer := R.Outer_Ref; - end if; - R.Alias := null; - end if; - end; - Top := Top - 1; - end loop; - end if; - end Finalize; - - function Get (Evt : in Ptr; + function Get (Env : in Instance; Key : in Symbols.Ptr) return Mal.T is - pragma Assert (Evt.Index in 1 | Top); - Index : Stack_Index := Evt.Index; - Ref : Heap_Access; - Definition : HM.Cursor; + -- Trust the compiler to detect the tail call. A loop would + -- require a Ptr parameter or a separated first iteration. + Position : constant HM.Cursor := Env.Data.Find (Key); begin - Main_Loop : loop - Index_Loop : loop - Definition := Stack (Index).Data.Find (Key); - if HM.Has_Element (Definition) then - return HM.Element (Definition); - end if; - exit Index_Loop when not Stack (Index).Outer_On_Stack; - Index := Stack (Index).Outer_Index; - exit Main_Loop when Index = 0; - end loop Index_Loop; - Ref := Stack (Index).Outer_Ref; - Ref_Loop : loop - Definition := Ref.all.Data.Find (Key); - if HM.Has_Element (Definition) then - return HM.Element (Definition); - end if; - exit Ref_Loop when Ref.all.Outer = null; - Ref := Ref.all.Outer; - end loop Ref_Loop; - Index := Ref.all.Index; - end loop Main_Loop; - Err.Raise_With ("'" & Key.To_String & "' not found"); + if HM.Has_Element (Position) then + return HM.Element (Position); + end if; + Err.Check (Env.Outer /= null, + "'" & Symbols.To_String (Key) & "' not found"); + return Env.Outer.all.Get (Key); end Get; - function New_Closure (Env : in Ptr'Class) return Closure_Ptr is - pragma Assert (Env.Index in 1 | Top); - Alias : Heap_Access renames Stack (Env.Index).Alias; + procedure Keep_References (Object : in out Instance) is + -- Same remarks than for Get. begin - if Alias = null then - Allocations := Allocations + 1; - Alias := new Heap_Record'(Index => Env.Index, others => <>); - else - Alias.all.Refs := @ + 1; + for Element of Object.Data loop + Mal.Keep (Element); + end loop; + if Object.Outer /= null then + Object.Outer.all.Keep; end if; - return (Ada.Finalization.Controlled with Alias); - end New_Closure; + end Keep_References; - procedure Replace_With_Sub (Env : in out Ptr) is - pragma Assert (Env.Index in 1 | Top); - R : Stack_Record renames Stack (Env.Index); - begin - if Env.Index < Top or 1 < R.Refs - or (R.Alias /= null and then 0 < R.Alias.all.Refs) - then - R.Refs := @ - 1; - Top := Top + 1; - pragma Assert (Stack (Top).Data.Is_Empty); - pragma Assert (Stack (Top).Alias = null); - Stack (Top) := (Outer_Index => Env.Index, - others => <>); - Env.Index := Top; - end if; - -- Else reuse the top stack record, including its map and its - -- unreferenced alias if any. - end Replace_With_Sub; - - procedure Replace_With_Sub (Env : in out Ptr; - Outer : in Closure_Ptr'Class; - Binds : in Symbols.Symbol_Array; - Exprs : in Mal.T_Array) - is - pragma Assert (Env.Index in 1 | Top); - begin - -- Finalize Env before creating the new environment, in case - -- this is the last reference and it can be forgotten. - -- Automatic assignment would construct the new value before - -- finalizing the old one. - Finalize (Env); - Outer.Ref.all.Refs := @ + 1; - Top := Top + 1; - pragma Assert (Stack (Top).Data.Is_Empty); - pragma Assert (Stack (Top).Alias = null); - Stack (Top) := (Outer_On_Stack => False, - Outer_Ref => Outer.Ref, - others => <>); - Env.Index := Top; - -- Now we can afford raising exceptions. - Set_Binds (Stack (Top).Data, Binds, Exprs); - end Replace_With_Sub; - - procedure Replace_With_Sub (Env : in out Ptr; - Binds : in Symbols.Symbol_Array; - Exprs : in Mal.T_Array) - is - pragma Assert (Env.Index in 1 | Top); - begin - Replace_With_Sub (Env); - Set_Binds (Stack (Top).Data, Binds, Exprs); - end Replace_With_Sub; - - procedure Set (Env : in Ptr; - Key : in Symbols.Ptr; - New_Element : in Mal.T) - is - pragma Assert (Env.Index in 1 | Top); - begin - Stack (Env.Index).Data.Include (Key, New_Element); - end Set; - - procedure Set_Binds (M : in out HM.Map; - Binds : in Symbols.Symbol_Array; - Exprs : in Mal.T_Array) + function New_Env (Outer : in Ptr := null; + Binds : in Symbols.Symbol_Array := No_Binds; + Exprs : in Mal.T_Array := No_Exprs) return Ptr is use type Symbols.Ptr; - Varargs : constant Boolean := 1 < Binds'Length and then - Binds (Binds'Last - 1) = Symbols.Names.Ampersand; + Ref : constant Ptr := new Instance'(Garbage_Collected.Instance with + Outer => Outer, + Data => HM.Empty_Map); begin - Err.Check ((if Varargs then Binds'Length - 2 <= Exprs'Length - else Exprs'Length = Binds'Length), - "actual parameters do not match formal parameters"); - for I in 0 .. Binds'Length - (if Varargs then 3 else 1) loop - M.Include (Binds (Binds'First + I), Exprs (Exprs'First + I)); - end loop; - if Varargs then - M.Include (Binds (Binds'Last), Sequences.List - (Exprs (Exprs'First + Binds'Length - 2 .. Exprs'Last))); + Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); + if 2 <= Binds'Length + and then Binds (Binds'Last - 1) = Symbols.Names.Ampersand + then + Err.Check (Binds'Length - 2 <= Exprs'Length, + "not enough actual parameters for vararg function"); + for I in 0 .. Binds'Length - 3 loop + Ref.all.Data.Include (Key => Binds (Binds'First + I), + New_Item => Exprs (Exprs'First + I)); + end loop; + Ref.all.Data.Include (Key => Binds (Binds'Last), + New_Item => Sequences.List + (Exprs (Exprs'First + Binds'Length - 2 .. Exprs'Last))); + else + Err.Check (Binds'Length = Exprs'Length, + "wrong parameter count for (not vararg) function"); + for I in 0 .. Binds'Length - 1 loop + Ref.all.Data.Include (Key => Binds (Binds'First + I), + New_Item => Exprs (Exprs'First + I)); + end loop; end if; - end Set_Binds; + return Ref; + end New_Env; - function Sub (Outer : in Ptr; - Binds : in Symbols.Symbol_Array; - Exprs : in Mal.T_Array) return Ptr - is - pragma Assert (Outer.Index in 1 | Top); - begin - Top := Top + 1; - pragma Assert (Stack (Top).Data.Is_Empty); - pragma Assert (Stack (Top).Alias = null); - Stack (Top) := (Outer_Index => Outer.Index, - others => <>); - Set_Binds (Stack (Top).Data, Binds, Exprs); - return (Ada.Finalization.Limited_Controlled with Top); - end Sub; - - function Sub (Outer : in Closure_Ptr'Class; - Binds : in Symbols.Symbol_Array; - Exprs : in Mal.T_Array) return Ptr + procedure Set (Env : in out Instance; + Key : in Symbols.Ptr; + New_Item : in Mal.T) is begin - Outer.Ref.all.Refs := @ + 1; - Top := Top + 1; - pragma Assert (Stack (Top).Data.Is_Empty); - pragma Assert (Stack (Top).Alias = null); - Stack (Top) := (Outer_On_Stack => False, - Outer_Ref => Outer.Ref, - others => <>); - -- Take care to construct the result before raising any - -- exception, so that it is finalized correctly. - return R : constant Ptr := (Ada.Finalization.Limited_Controlled with Top) - do - -- Now we can afford raising exceptions. - Set_Binds (Stack (Top).Data, Binds, Exprs); - end return; - end Sub; - - procedure Unreference (Reference : in out Heap_Access) is - Ref : Heap_Access := Reference; - begin - Reference := null; - loop - exit when Ref = null; - exit when Ref.all.Refs = 0; - Ref.all.Refs := @ - 1; - exit when 0 < Ref.all.Refs; - exit when Ref.all.Outer = null; -- An alias. Do not free it - -- now, it may be useful for another closure. - declare - Tmp : Heap_Access := Ref; - begin - Ref := Ref.all.Outer; - Allocations := Allocations - 1; - Free (Tmp); - pragma Unreferenced (Tmp); - end; - end loop; - end Unreference; + Env.Data.Include (Key, New_Item); + end Set; end Envs; diff --git a/ada.2/envs.ads b/ada.2/envs.ads index f47d7744..94955e5e 100644 --- a/ada.2/envs.ads +++ b/ada.2/envs.ads @@ -1,138 +1,49 @@ -private with Ada.Finalization; +private with Ada.Containers.Hashed_Maps; +with Garbage_Collected; with Types.Mal; with Types.Symbols; -package Envs with Elaborate_Body is +package Envs is -- This package should be named Env, but Ada does not allow formal -- parameters to be named like a package dependency, and it seems -- that readability inside Eval is more important. - -- This implementation relies on the fact that the caller only - -- ever references environments in its execution stack. + type Instance (<>) is new Garbage_Collected.Instance with private; + type Ptr is access Instance; - -- When a function closure references an environment that the - -- execution leaves behind, a dynamically allocated block is used - -- instead. + No_Binds : Types.Symbols.Symbol_Array renames Types.Symbols.Empty_Array; + No_Exprs : constant Types.Mal.T_Array := (1 .. 0 => Types.Mal.Nil); - -- The eval built-in requires REPL (see the implementation of - -- load-file), so we cannot assume that the caller only sees the - -- current environment. + function New_Env (Outer : in Ptr := null; + Binds : in Types.Symbols.Symbol_Array := No_Binds; + Exprs : in Types.Mal.T_Array := No_Exprs) + return Ptr; - type Ptr (<>) is tagged limited private; - -- This type is controlled in order count the references to a - -- given environment, even during exception propagation. - -- Since Ptr is limited with a hidden discriminant, any variable - -- must immediately be assigned with one of - -- * Copy_Pointer, - -- * Sub (either from a Ptr or from a Closure_Ptr). - -- Usual assignment with reference counting is not provided - -- because we want to enforce the use of the more efficient - -- Replace_With_Sub. - - Repl : constant Ptr; - -- The top environment. - - function Copy_Pointer (Env : in Ptr) return Ptr with Inline; - -- Allows assignment to a freshly created variable. This is - -- required for tail call optimization, but should be avoided - -- elsewhere. - - procedure Replace_With_Sub (Env : in out Ptr) with Inline; - -- for let* - - procedure Replace_With_Sub (Env : in out Ptr; - Binds : in Types.Symbols.Symbol_Array; - Exprs : in Types.Mal.T_Array) with Inline; - -- when expanding macros. - - procedure Set (Env : in Ptr; - Key : in Types.Symbols.Ptr; - New_Element : in Types.Mal.T) - with Inline; - - -- The Find method is merged into the Get method. - - function Get (Evt : in Ptr; + function Get (Env : in Instance; Key : in Types.Symbols.Ptr) return Types.Mal.T; - -- Raises Core.Error_Exception if the key is not found. - -- Function closures. + procedure Set (Env : in out Instance; + Key : in Types.Symbols.Ptr; + New_Item : in Types.Mal.T) with Inline; - type Closure_Ptr is tagged private; - Null_Closure : constant Closure_Ptr; - - function New_Closure (Env : in Ptr'Class) return Closure_Ptr; - -- The class-wide argument does not make much sense, but avoids - -- the compiler wondering on which type is should dispatch. - - function Sub (Outer : in Closure_Ptr'Class; - Binds : in Types.Symbols.Symbol_Array; - Exprs : in Types.Mal.T_Array) return Ptr; - -- when applying functions without tail call optimization. - -- Construct a new environment with the given outer parent. - -- Then call Set with the paired elements of Binds and Exprs, - -- handling the "&" special formal parameter if present. - -- May raise Error. - - procedure Replace_With_Sub (Env : in out Ptr; - Outer : in Closure_Ptr'Class; - Binds : in Types.Symbols.Symbol_Array; - Exprs : in Types.Mal.T_Array); - -- when applying functions with tail call optimization. - -- Equivalent to Env := Sub (Env, Binds, Exprs), except that such - -- an assignment is forbidden or discouraged for performance reasons. - - function Sub (Outer : in Ptr; - Binds : in Types.Symbols.Symbol_Array; - Exprs : in Types.Mal.T_Array) return Ptr; - -- when applying macros - - -- Debugging. - procedure Dump_Stack (Long : in Boolean); - procedure Clear_And_Check_Allocations; + -- Debug. + procedure Dump_Stack (Env : in Instance); private - -- There must be a reference level so that functions may keep - -- track of their initial environment, and another one for - -- reallocations. The second one is delegated to a predefined Ada - -- container. + package HM is new Ada.Containers.Hashed_Maps + (Key_Type => Types.Symbols.Ptr, + Element_Type => Types.Mal.T, + Hash => Types.Symbols.Hash, + Equivalent_Keys => Types.Symbols."=", + "=" => Types.Mal."="); - -- MAL maps may be tempting, but we do not want to copy the whole - -- map for each addition or removal. - - -- Some tests seem to show that a hashmap is three times faster - -- than a vector with (key, value) couples. - - -- We allow the null value so that the empty environment in a - -- macro does not trigger an allocation. - - type Stack_Index is range 0 .. 200; - - -- See README for the implementation of reference counting. - - type Ptr is new Ada.Finalization.Limited_Controlled with record - Index : Stack_Index := 0; - end record - with Invariant => Ptr.Index in 1 .. Top; - overriding procedure Finalize (Object : in out Ptr) with Inline; - pragma Finalize_Storage_Only (Ptr); - - Top : Stack_Index := 1; - Repl : constant Ptr := (Ada.Finalization.Limited_Controlled with 1); - - type Heap_Record; - type Heap_Access is access Heap_Record; - type Closure_Ptr is new Ada.Finalization.Controlled with record - Ref : Heap_Access := null; + type Instance is new Garbage_Collected.Instance with record + Outer : Ptr; + Data : HM.Map; end record; - overriding procedure Adjust (Object : in out Closure_Ptr) with Inline; - overriding procedure Finalize (Object : in out Closure_Ptr) with Inline; - pragma Finalize_Storage_Only (Closure_Ptr); - - Null_Closure : constant Closure_Ptr - := (Ada.Finalization.Controlled with null); + overriding procedure Keep_References (Object : in out Instance) with Inline; end Envs; diff --git a/ada.2/garbage_collected.adb b/ada.2/garbage_collected.adb new file mode 100644 index 00000000..0552a064 --- /dev/null +++ b/ada.2/garbage_collected.adb @@ -0,0 +1,54 @@ +with Ada.Unchecked_Deallocation; + +package body Garbage_Collected is + + procedure Free is new Ada.Unchecked_Deallocation (Class, Pointer); + + Top : Pointer := null; + + ---------------------------------------------------------------------- + + procedure Clean is + Current : Pointer := Top; + Previous : Pointer; + begin + while Current /= null and then not Current.all.Kept loop + Previous := Current; + Current := Current.all.Next; + Free (Previous); + end loop; + Top := Current; + while Current /= null loop + if Current.all.Kept then + Current.all.Kept := False; + Previous := Current; + else + Previous.all.Next := Current.all.Next; + Free (Current); + end if; + Current := Previous.all.Next; + end loop; + end Clean; + + procedure Keep (Object : in out Instance) is + begin + if not Object.Kept then + Object.Kept := True; + Class (Object).Keep_References; -- dispatching + end if; + end Keep; + + procedure Check_Allocations is + begin + pragma Assert (Top = null); + end Check_Allocations; + + procedure Register (Ref : in not null Pointer) is + begin + pragma Assert (Ref.all.Kept = False); + pragma Assert (Ref.all.Next = null); + Ref.all.Next := Top; + Top := Ref; + end Register; + +end Garbage_Collected; diff --git a/ada.2/garbage_collected.ads b/ada.2/garbage_collected.ads new file mode 100644 index 00000000..e91c994e --- /dev/null +++ b/ada.2/garbage_collected.ads @@ -0,0 +1,45 @@ +package Garbage_Collected with Preelaborate is + + -- A generic would not be convenient for lists. We want the + -- extended type to be able to have a discriminant. + + -- However, we keep the dispatching in a single enumeration for + -- efficiency and clarity of the source. + + type Instance is abstract tagged limited private; + subtype Class is Instance'Class; + type Pointer is access all Class; + + procedure Keep_References (Object : in out Instance) is null with Inline; + -- A dispatching call in Keep allows subclasses to override this + -- in order to Keep each of the internal reference they maintain. + + -- The following methods have no reason to be overridden. + + procedure Keep (Object : in out Instance) with Inline; + -- Mark this object so that it is not deleted by next clean, + -- then make a dispatching call to Keep_References. + -- Does nothing if it has already been called for this object + -- since startup or last Clean. + + procedure Register (Ref : in not null Pointer) with Inline; + -- Each subclass defines its own allocation pool, but every call + -- to new must be followed by a call to Register. + + procedure Clean; + -- For each object for which Keep has not been called since + -- startup or last clean, make a dispatching call to Finalize, + -- then deallocate the memory for the object. + + -- Debug. + procedure Check_Allocations with Inline; + -- Does nothing if assertions are disabled. + +private + + type Instance is abstract tagged limited record + Kept : Boolean := False; + Next : Pointer := null; + end record; + +end Garbage_Collected; diff --git a/ada.2/printer.adb b/ada.2/printer.adb index f5ddb4de..e3a0c805 100644 --- a/ada.2/printer.adb +++ b/ada.2/printer.adb @@ -22,10 +22,10 @@ package body Printer is -- Helpers for Print_Form. procedure Print_Number (Number : in Integer) with Inline; - procedure Print_List (List : in Sequences.Ptr) with Inline; - procedure Print_Map (Map : in Maps.Ptr) with Inline; + procedure Print_List (List : in Sequences.Instance) with Inline; + procedure Print_Map (Map : in Maps.Instance) with Inline; procedure Print_Readably (S : in Unbounded_String) with Inline; - procedure Print_Function (Fn : in Fns.Ptr) with Inline; + procedure Print_Function (Fn : in Fns.Instance) with Inline; ---------------------------------------------------------------------- @@ -41,7 +41,7 @@ package body Printer is Append (Buffer, "false"); end if; when Kind_Symbol => - Append (Buffer, Form_Ast.Symbol.To_String); + Append (Buffer, Symbols.To_String (Form_Ast.Symbol)); when Kind_Number => Print_Number (Form_Ast.Number); when Kind_Keyword => @@ -57,34 +57,34 @@ package body Printer is end if; when Kind_List => Append (Buffer, '('); - Print_List (Form_Ast.Sequence); + Print_List (Form_Ast.Sequence.all); Append (Buffer, ')'); when Kind_Vector => Append (Buffer, '['); - Print_List (Form_Ast.Sequence); + Print_List (Form_Ast.Sequence.all); Append (Buffer, ']'); when Kind_Map => Append (Buffer, '{'); - Print_Map (Form_Ast.Map); + Print_Map (Form_Ast.Map.all); Append (Buffer, '}'); when Kind_Builtin | Kind_Builtin_With_Meta => Append (Buffer, "#"); when Kind_Fn => Append (Buffer, "#'); when Kind_Macro => Append (Buffer, "#'); when Kind_Atom => Append (Buffer, "(atom "); - Print_Form (Atoms.Deref (Form_Ast.Atom)); + Print_Form (Form_Ast.Atom.all.Deref); Append (Buffer, ')'); end case; end Print_Form; - procedure Print_Function (Fn : in Fns.Ptr) is + procedure Print_Function (Fn : in Fns.Instance) is Started : Boolean := False; begin Append (Buffer, '('); @@ -94,13 +94,13 @@ package body Printer is else Started := True; end if; - Append (Buffer, Param.To_String); + Append (Buffer, Symbols.To_String (Param)); end loop; Append (Buffer, ") -> "); Print_Form (Fn.Ast); end Print_Function; - procedure Print_List (List : in Sequences.Ptr) is + procedure Print_List (List : in Sequences.Instance) is begin if 0 < List.Length then Print_Form (List (1)); @@ -111,7 +111,7 @@ package body Printer is end if; end Print_List; - procedure Print_Map (Map : in Maps.Ptr) is + procedure Print_Map (Map : in Maps.Instance) is procedure Process (Key : in Mal.T; Element : in Mal.T) with Inline; procedure Iterate is new Maps.Iterate (Process); diff --git a/ada.2/reader.adb b/ada.2/reader.adb index 99d5c57c..1af4162b 100644 --- a/ada.2/reader.adb +++ b/ada.2/reader.adb @@ -13,7 +13,7 @@ with Types.Symbols.Names; package body Reader is - Debug : constant Boolean := Ada.Environment_Variables.Exists ("dbg_reader"); + Debug : constant Boolean := Ada.Environment_Variables.Exists ("dbgread"); use Types; use type Ada.Strings.Maps.Character_Set; @@ -37,7 +37,7 @@ package body Reader is B_Last : Natural := Buffer'First - 1; -- Index in Buffer of the currently written MAL expression. - procedure Read_Form; + function Read_Form return Mal.T; -- The recursive part of Read_Str. -- Helpers for Read_Form: @@ -58,124 +58,127 @@ package body Reader is -- Read_Atom has been merged into the same case/switch -- statement, for clarity and efficiency. - procedure Read_List (Ending : in Character; - Constructor : in not null Mal.Builtin_Ptr) - with Inline; - procedure Read_Quote (Symbol : in Symbols.Ptr) with Inline; - procedure Read_String with Inline; - procedure Read_With_Meta with Inline; + + function Read_List (Ending : in Character) return Natural with Inline; + -- Returns the index of the last elements in Buffer. + -- The elements have been stored in Buffer (B_Last .. result). + + function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T with Inline; + + function Read_String return Mal.T with Inline; + + function Read_With_Meta return Mal.T with Inline; ---------------------------------------------------------------------- - procedure Read_List (Ending : in Character; - Constructor : in not null Mal.Builtin_Ptr) is + function Read_List (Ending : in Character) return Natural is Opening : constant Character := Source (I); - B_First : constant Positive := B_Last; + Old : constant Natural := B_Last; + Result : Positive; begin I := I + 1; -- Skip (, [ or {. loop Skip_Ignored; Err.Check (I <= Source'Last, "unbalanced '" & Opening & "'"); exit when Source (I) = Ending; - Read_Form; B_Last := B_Last + 1; + Buffer (B_Last) := Read_Form; end loop; I := I + 1; -- Skip ), ] or }. - Buffer (B_First) := Constructor.all (Buffer (B_First .. B_Last - 1)); - B_Last := B_First; + Result := B_Last; + B_Last := Old; + return Result; end Read_List; - procedure Read_Quote (Symbol : in Symbols.Ptr) is + function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T is + R : constant Mal.Sequence_Ptr := Sequences.Constructor (2); begin - Buffer (B_Last) := (Kind_Symbol, Symbol); I := I + 1; -- Skip the initial ' or similar. + R.Replace_Element (1, (Kind_Symbol, Symbol)); Skip_Ignored; - Err.Check (I <= Source'Last, "Incomplete '" & Symbol.To_String & "'"); - B_Last := B_Last + 1; - Read_Form; - B_Last := B_Last - 1; - Buffer (B_Last) := Sequences.List (Buffer (B_Last .. B_Last + 1)); + Err.Check (I <= Source'Last, + "Incomplete '" & Symbols.To_String (Symbol) & "'"); + R.Replace_Element (2, Read_Form); + return (Kind_List, R); end Read_Quote; - procedure Read_Form is + function Read_Form return Mal.T is -- After I has been increased, current token is be -- Source (F .. I - 1). F : Positive; + R : Mal.T; -- The result of this function. begin case Source (I) is when ')' | ']' | '}' => Err.Raise_With ("unbalanced '" & Source (I) & "'"); when '"' => - Read_String; + R := Read_String; when ':' => I := I + 1; F := I; Skip_Symbol; - Buffer (B_Last) := (Kind_Keyword, - Ada.Strings.Unbounded.To_Unbounded_String - (Source (F .. I - 1))); + R := (Kind_Keyword, Ada.Strings.Unbounded.To_Unbounded_String + (Source (F .. I - 1))); when '-' => F := I; Skip_Digits; if F + 1 < I then - Buffer (B_Last) := (Kind_Number, - Integer'Value (Source (F .. I - 1))); + R := (Kind_Number, Integer'Value (Source (F .. I - 1))); else Skip_Symbol; - Buffer (B_Last) := (Kind_Symbol, - Symbols.Constructor (Source (F .. I - 1))); + R := (Kind_Symbol, + Symbols.Constructor (Source (F .. I - 1))); end if; when '~' => if I < Source'Last and then Source (I + 1) = '@' then I := I + 1; - Read_Quote (Symbols.Names.Splice_Unquote); + R := Read_Quote (Symbols.Names.Splice_Unquote); else - Read_Quote (Symbols.Names.Unquote); + R := Read_Quote (Symbols.Names.Unquote); end if; when '0' .. '9' => F := I; Skip_Digits; - Buffer (B_Last) := (Kind_Number, - Integer'Value (Source (F .. I - 1))); + R := (Kind_Number, Integer'Value (Source (F .. I - 1))); when ''' => - Read_Quote (Symbols.Names.Quote); + R := Read_Quote (Symbols.Names.Quote); when '`' => - Read_Quote (Symbols.Names.Quasiquote); + R := Read_Quote (Symbols.Names.Quasiquote); when '@' => - Read_Quote (Symbols.Names.Deref); + R := Read_Quote (Symbols.Names.Deref); when '^' => - Read_With_Meta; + R := Read_With_Meta; when '(' => - Read_List (')', Sequences.List'Access); + R := Sequences.List (Buffer (B_Last + 1 .. Read_List (')'))); when '[' => - Read_List (']', Sequences.Vector'Access); + R := Sequences.Vector (Buffer (B_Last + 1 .. Read_List (']'))); when '{' => - Read_List ('}', Maps.Hash_Map'Access); + R := Maps.Hash_Map (Buffer (B_Last + 1 .. Read_List ('}'))); when others => F := I; Skip_Symbol; if Source (F .. I - 1) = "false" then - Buffer (B_Last) := (Kind_Boolean, False); + R := (Kind_Boolean, False); elsif Source (F .. I - 1) = "nil" then - Buffer (B_Last) := Mal.Nil; + R := Mal.Nil; elsif Source (F .. I - 1) = "true" then - Buffer (B_Last) := (Kind_Boolean, True); + R := (Kind_Boolean, True); else - Buffer (B_Last) := (Kind_Symbol, - Symbols.Constructor (Source (F .. I - 1))); + R := (Kind_Symbol, + Symbols.Constructor (Source (F .. I - 1))); end if; end case; if Debug then Ada.Text_IO.Put ("reader: "); - Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Buffer - (B_Last))); + Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (R)); end if; + return R; end Read_Form; - procedure Read_String is + function Read_String return Mal.T is use Ada.Strings.Unbounded; + Result : Unbounded_String; begin - Buffer (B_Last) := (Kind_String, Null_Unbounded_String); loop I := I + 1; Err.Check (I <= Source'Last, "unbalanced '""'"); @@ -187,33 +190,31 @@ package body Reader is Err.Check (I <= Source'Last, "unbalanced '""'"); case Source (I) is when '\' | '"' => - Append (Buffer (B_Last).S, Source (I)); + Append (Result, Source (I)); when 'n' => - Append (Buffer (B_Last).S, Ada.Characters.Latin_1.LF); + Append (Result, Ada.Characters.Latin_1.LF); when others => - Append (Buffer (B_Last).S, Source (I - 1 .. I)); + Append (Result, Source (I - 1 .. I)); end case; when others => - Append (Buffer (B_Last).S, Source (I)); + Append (Result, Source (I)); end case; end loop; I := I + 1; -- Skip closing double quote. + return (Kind_String, Result); end Read_String; - procedure Read_With_Meta is + function Read_With_Meta return Mal.T is + List : constant Mal.Sequence_Ptr := Sequences.Constructor (3); begin I := I + 1; -- Skip the initial ^. - for Argument in 1 .. 2 loop + List.all.Replace_Element (1, (Kind_Symbol, Symbols.Names.With_Meta)); + for I in reverse 2 .. 3 loop Skip_Ignored; Err.Check (I <= Source'Last, "Incomplete 'with-meta'"); - Read_Form; - B_Last := B_Last + 1; + List.all.Replace_Element (I, Read_Form); end loop; - -- Replace (metadata data) with (with-meta data metadata). - B_Last := B_Last - 2; - Buffer (B_Last + 2) := Buffer (B_Last); - Buffer (B_Last) := (Kind_Symbol, Symbols.Names.With_Meta); - Buffer (B_Last) := Sequences.List (Buffer (B_Last .. B_Last + 2)); + return (Kind_List, List); end Read_With_Meta; procedure Skip_Digits is @@ -259,7 +260,7 @@ package body Reader is Skip_Ignored; exit when Source'Last < I; B_Last := B_Last + 1; - Read_Form; + Buffer (B_Last) := Read_Form; end loop; return Buffer (Buffer'First .. B_Last); end Read_Str; diff --git a/ada.2/step1_read_print.adb b/ada.2/step1_read_print.adb index f0e3ad68..51aaaa39 100644 --- a/ada.2/step1_read_print.adb +++ b/ada.2/step1_read_print.adb @@ -1,15 +1,11 @@ with Ada.Text_IO.Unbounded_IO; with Err; +with Garbage_Collected; with Printer; with Reader; with Readline; -with Types.Atoms; -with Types.Builtins; -with Types.Fns; with Types.Mal; -with Types.Maps; -with Types.Sequences; with Types.Symbols; procedure Step1_Read_Print is @@ -56,14 +52,14 @@ begin Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Mal.Nil; + Garbage_Collected.Clean; end loop; Ada.Text_IO.New_Line; -- If assertions are enabled, check deallocations. - Err.Data := Mal.Nil; -- Remove references to other packages - pragma Debug (Atoms.Check_Allocations); - pragma Debug (Builtins.Check_Allocations); - pragma Debug (Fns.Check_Allocations); - pragma Debug (Maps.Check_Allocations); - pragma Debug (Sequences.Check_Allocations); - pragma Debug (Symbols.Check_Allocations); + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; + Symbols.Check_Allocations; end Step1_Read_Print; diff --git a/ada.2/step2_eval.adb b/ada.2/step2_eval.adb index a8928f85..44abc648 100644 --- a/ada.2/step2_eval.adb +++ b/ada.2/step2_eval.adb @@ -4,12 +4,10 @@ with Ada.Strings.Hash; with Ada.Text_IO.Unbounded_IO; with Err; +with Garbage_Collected; with Printer; with Reader; with Readline; -with Types.Atoms; -with Types.Builtins; -with Types.Fns; with Types.Mal; with Types.Maps; with Types.Sequences; @@ -41,7 +39,6 @@ procedure Step2_Eval is with function Ada_Operator (Left, Right : in Integer) return Integer; function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T; - function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Map, Eval); function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Map, Eval); ---------------------------------------------------------------------- @@ -56,6 +53,7 @@ procedure Step2_Eval is Ada.Text_IO.Put ("EVAL: "); Print (Ast); end if; + case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key | Kind_Macro | Kind_Function => @@ -70,29 +68,40 @@ procedure Step2_Eval is return (Kind_Builtin, Envs.Element (C)); end; when Kind_Map => - return Eval_Map_Elts (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map.all, Env); when Kind_Vector => - return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); + declare + Len : constant Natural := Ast.Sequence.all.Length; + List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len); + begin + for I in 1 .. Len loop + List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env)); + end loop; + return (Kind_Vector, List); + end; when Kind_List => null; end case; -- Ast is a list. - if Ast.Sequence.Length = 0 then + if Ast.Sequence.all.Length = 0 then return Ast; end if; - First := Eval (Ast.Sequence (1), Env); + First := Ast.Sequence.all (1); + + -- Ast is a non-empty list, First is its first element. + First := Eval (First, Env); -- Apply phase. -- Ast is a non-empty list, - -- First is its non-special evaluated first element. + -- First is its evaluated first element. case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.Sequence.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.all.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.Sequence (I), Env); + Args (I) := Eval (Ast.Sequence.all (I), Env); end loop; return First.Builtin.all (Args); end; @@ -147,14 +156,15 @@ begin Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Mal.Nil; + Garbage_Collected.Clean; end loop; Ada.Text_IO.New_Line; + -- If assertions are enabled, check deallocations. - Err.Data := Mal.Nil; -- Remove references to other packages - pragma Debug (Atoms.Check_Allocations); - pragma Debug (Builtins.Check_Allocations); - pragma Debug (Fns.Check_Allocations); - pragma Debug (Maps.Check_Allocations); - pragma Debug (Sequences.Check_Allocations); - pragma Debug (Symbols.Check_Allocations); + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; + Symbols.Check_Allocations; end Step2_Eval; diff --git a/ada.2/step3_env.adb b/ada.2/step3_env.adb index 80724bb7..3a15ff25 100644 --- a/ada.2/step3_env.adb +++ b/ada.2/step3_env.adb @@ -3,12 +3,10 @@ with Ada.Text_IO.Unbounded_IO; with Envs; with Err; +with Garbage_Collected; with Printer; with Reader; with Readline; -with Types.Atoms; -with Types.Builtins; -with Types.Fns; with Types.Mal; with Types.Maps; with Types.Sequences; @@ -16,11 +14,7 @@ with Types.Symbols.Names; procedure Step3_Env is - Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1"); - Dbgenv0 : constant Boolean - := Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0"); - Dbgeval : constant Boolean - := Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval"); + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); use Types; @@ -37,7 +31,6 @@ procedure Step3_Env is with function Ada_Operator (Left, Right : in Integer) return Integer; function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T; - function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval); function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); ---------------------------------------------------------------------- @@ -52,60 +45,67 @@ procedure Step3_Env is Ada.Text_IO.New_Line; Ada.Text_IO.Put ("EVAL: "); Print (Ast); - if Dbgenv0 then - Envs.Dump_Stack (Long => Dbgenv1); - end if; + Envs.Dump_Stack (Env.all); end if; + case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key | Kind_Macro | Kind_Function => return Ast; when Kind_Symbol => - return Env.Get (Ast.Symbol); + return Env.all.Get (Ast.Symbol); when Kind_Map => - return Eval_Map_Elts (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map.all, Env); when Kind_Vector => - return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); + declare + Len : constant Natural := Ast.Sequence.all.Length; + List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len); + begin + for I in 1 .. Len loop + List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env)); + end loop; + return (Kind_Vector, List); + end; when Kind_List => null; end case; -- Ast is a list. - if Ast.Sequence.Length = 0 then + if Ast.Sequence.all.Length = 0 then return Ast; end if; - First := Ast.Sequence (1); + First := Ast.Sequence.all (1); -- Special forms -- Ast is a non-empty list, First is its first element. case First.Kind is when Kind_Symbol => if First.Symbol = Symbols.Names.Def then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol, "parameter 1 must be a symbol"); - return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do - Env.Set (Ast.Sequence (2).Symbol, R); + return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do + Env.all.Set (Ast.Sequence.all (2).Symbol, R); end return; elsif First.Symbol = Symbols.Names.Let then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence, "parameter 1 must be a sequence"); declare - Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence; - -- This curious syntax is useful for later steps. - New_Env : Envs.Ptr := Env.Copy_Pointer; + Bindings : constant Mal.Sequence_Ptr + := Ast.Sequence.all (2).Sequence; + New_Env : Envs.Ptr; begin - Err.Check (Bindings.Length mod 2 = 0, + Err.Check (Bindings.all.Length mod 2 = 0, "parameter 1 must have an even length"); - New_Env.Replace_With_Sub; - for I in 1 .. Bindings.Length / 2 loop - Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol, + New_Env := Envs.New_Env (Outer => Env); + for I in 1 .. Bindings.all.Length / 2 loop + Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol, "binding keys must be symbols"); - New_Env.Set (Bindings (2 * I - 1).Symbol, - Eval (Bindings (2 * I), New_Env)); + New_Env.all.Set (Bindings.all (2 * I - 1).Symbol, + Eval (Bindings.all (2 * I), New_Env)); end loop; - return Eval (Ast.Sequence (3), New_Env); + return Eval (Ast.Sequence.all (3), New_Env); end; else First := Eval (First, Env); @@ -120,10 +120,10 @@ procedure Step3_Env is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.Sequence.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.all.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.Sequence (I), Env); + Args (I) := Eval (Ast.Sequence.all (I), Env); end loop; return First.Builtin.all (Args); end; @@ -162,16 +162,18 @@ procedure Step3_Env is function Product is new Generic_Mal_Operator ("*"); function Division is new Generic_Mal_Operator ("/"); - Repl : Envs.Ptr renames Envs.Repl; + Repl : constant Envs.Ptr := Envs.New_Env; begin - Repl.Set (Symbols.Constructor ("+"), - (Kind_Builtin, Addition 'Unrestricted_Access)); - Repl.Set (Symbols.Constructor ("-"), - (Kind_Builtin, Subtraction'Unrestricted_Access)); - Repl.Set (Symbols.Constructor ("*"), - (Kind_Builtin, Product 'Unrestricted_Access)); - Repl.Set (Symbols.Constructor ("/"), - (Kind_Builtin, Division 'Unrestricted_Access)); + -- Add Core functions into the top environment. + Repl.all.Set (Symbols.Constructor ("+"), + (Kind_Builtin, Addition 'Unrestricted_Access)); + Repl.all.Set (Symbols.Constructor ("-"), + (Kind_Builtin, Subtraction'Unrestricted_Access)); + Repl.all.Set (Symbols.Constructor ("*"), + (Kind_Builtin, Product 'Unrestricted_Access)); + Repl.all.Set (Symbols.Constructor ("/"), + (Kind_Builtin, Division 'Unrestricted_Access)); + -- Execute user commands. loop begin Rep (Repl); @@ -182,15 +184,16 @@ begin Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Mal.Nil; + Repl.all.Keep; + Garbage_Collected.Clean; end loop; Ada.Text_IO.New_Line; + -- If assertions are enabled, check deallocations. - Err.Data := Mal.Nil; -- Remove references to other packages - pragma Debug (Envs.Clear_And_Check_Allocations); - pragma Debug (Atoms.Check_Allocations); - pragma Debug (Builtins.Check_Allocations); - pragma Debug (Fns.Check_Allocations); - pragma Debug (Maps.Check_Allocations); - pragma Debug (Sequences.Check_Allocations); - pragma Debug (Symbols.Check_Allocations); + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; + Symbols.Check_Allocations; end Step3_Env; diff --git a/ada.2/step4_if_fn_do.adb b/ada.2/step4_if_fn_do.adb index 55bcbc6f..3dd53e8e 100644 --- a/ada.2/step4_if_fn_do.adb +++ b/ada.2/step4_if_fn_do.adb @@ -5,11 +5,10 @@ with Core; with Envs; with Err; with Eval_Cb; +with Garbage_Collected; with Printer; with Reader; with Readline; -with Types.Atoms; -with Types.Builtins; with Types.Fns; with Types.Mal; with Types.Maps; @@ -18,11 +17,7 @@ with Types.Symbols.Names; procedure Step4_If_Fn_Do is - Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1"); - Dbgenv0 : constant Boolean - := Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0"); - Dbgeval : constant Boolean - := Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval"); + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); use Types; use type Mal.T; @@ -36,7 +31,6 @@ procedure Step4_If_Fn_Do is procedure Rep (Env : in Envs.Ptr) with Inline; - function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval); function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); procedure Exec (Script : in String; @@ -55,82 +49,90 @@ procedure Step4_If_Fn_Do is Ada.Text_IO.New_Line; Ada.Text_IO.Put ("EVAL: "); Print (Ast); - if Dbgenv0 then - Envs.Dump_Stack (Long => Dbgenv1); - end if; + Envs.Dump_Stack (Env.all); end if; + case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key | Kind_Macro | Kind_Function => return Ast; when Kind_Symbol => - return Env.Get (Ast.Symbol); + return Env.all.Get (Ast.Symbol); when Kind_Map => - return Eval_Map_Elts (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map.all, Env); when Kind_Vector => - return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); + declare + Len : constant Natural := Ast.Sequence.all.Length; + List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len); + begin + for I in 1 .. Len loop + List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env)); + end loop; + return (Kind_Vector, List); + end; when Kind_List => null; end case; -- Ast is a list. - if Ast.Sequence.Length = 0 then + if Ast.Sequence.all.Length = 0 then return Ast; end if; - First := Ast.Sequence (1); + First := Ast.Sequence.all (1); -- Special forms -- Ast is a non-empty list, First is its first element. case First.Kind is when Kind_Symbol => if First.Symbol = Symbols.Names.Def then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol, "parameter 1 must be a symbol"); - return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do - Env.Set (Ast.Sequence (2).Symbol, R); + return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do + Env.all.Set (Ast.Sequence.all (2).Symbol, R); end return; -- do is a built-in function, shortening this test cascade. elsif First.Symbol = Symbols.Names.Fn then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence, "parameter 1 must be a sequence"); - return Fns.New_Function (Params => Ast.Sequence (2).Sequence, - Ast => Ast.Sequence (3), - Env => Env.New_Closure); + return Fns.New_Function + (Params => Ast.Sequence.all (2).Sequence.all, + Ast => Ast.Sequence.all (3), + Env => Env); elsif First.Symbol = Symbols.Names.Mal_If then - Err.Check (Ast.Sequence.Length in 3 .. 4, + Err.Check (Ast.Sequence.all.Length in 3 .. 4, "expected 2 or 3 parameters"); declare - Test : constant Mal.T := Eval (Ast.Sequence (2), Env); + Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env); begin if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then - return Eval (Ast.Sequence (3), Env); - elsif Ast.Sequence.Length = 3 then + return Eval (Ast.Sequence.all (3), Env); + elsif Ast.Sequence.all.Length = 3 then return Mal.Nil; else - return Eval (Ast.Sequence (4), Env); + return Eval (Ast.Sequence.all (4), Env); end if; end; elsif First.Symbol = Symbols.Names.Let then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence, "parameter 1 must be a sequence"); declare - Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence; - -- This curious syntax is useful for later steps. - New_Env : Envs.Ptr := Env.Copy_Pointer; + Bindings : constant Mal.Sequence_Ptr + := Ast.Sequence.all (2).Sequence; + New_Env : Envs.Ptr; begin - Err.Check (Bindings.Length mod 2 = 0, + Err.Check (Bindings.all.Length mod 2 = 0, "parameter 1 must have an even length"); - New_Env.Replace_With_Sub; - for I in 1 .. Bindings.Length / 2 loop - Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol, + New_Env := Envs.New_Env (Outer => Env); + for I in 1 .. Bindings.all.Length / 2 loop + Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol, "binding keys must be symbols"); - New_Env.Set (Bindings (2 * I - 1).Symbol, - Eval (Bindings (2 * I), New_Env)); + New_Env.all.Set (Bindings.all (2 * I - 1).Symbol, + Eval (Bindings.all (2 * I), New_Env)); end loop; - return Eval (Ast.Sequence (3), New_Env); + return Eval (Ast.Sequence.all (3), New_Env); end; else First := Eval (First, Env); @@ -145,21 +147,21 @@ procedure Step4_If_Fn_Do is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.Sequence.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.all.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.Sequence (I), Env); + Args (I) := Eval (Ast.Sequence.all (I), Env); end loop; return First.Builtin.all (Args); end; when Kind_Fn => declare - Args : Mal.T_Array (2 .. Ast.Sequence.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.all.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.Sequence (I), Env); + Args (I) := Eval (Ast.Sequence.all (I), Env); end loop; - return First.Fn.Apply (Args); + return First.Fn.all.Apply (Args); end; when others => Err.Raise_With ("first element must be a function"); @@ -200,14 +202,15 @@ procedure Step4_If_Fn_Do is Startup : constant String := "(def! not (fn* (a) (if a false true)))"; - Repl : Envs.Ptr renames Envs.Repl; + Repl : constant Envs.Ptr := Envs.New_Env; begin -- Show the Eval function to other packages. Eval_Cb.Cb := Eval'Unrestricted_Access; -- Add Core functions into the top environment. - Core.NS_Add_To_Repl; + Core.NS_Add_To_Repl (Repl); -- Native startup procedure. Exec (Startup, Repl); + -- Execute user commands. loop begin Rep (Repl); @@ -218,15 +221,16 @@ begin Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Mal.Nil; + Repl.all.Keep; + Garbage_Collected.Clean; end loop; Ada.Text_IO.New_Line; + -- If assertions are enabled, check deallocations. - Err.Data := Mal.Nil; -- Remove references to other packages - pragma Debug (Envs.Clear_And_Check_Allocations); - pragma Debug (Atoms.Check_Allocations); - pragma Debug (Builtins.Check_Allocations); - pragma Debug (Fns.Check_Allocations); - pragma Debug (Maps.Check_Allocations); - pragma Debug (Sequences.Check_Allocations); - pragma Debug (Symbols.Check_Allocations); + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; + Symbols.Check_Allocations; end Step4_If_Fn_Do; diff --git a/ada.2/step5_tco.adb b/ada.2/step5_tco.adb index 456ae976..c3baf5a8 100644 --- a/ada.2/step5_tco.adb +++ b/ada.2/step5_tco.adb @@ -5,11 +5,10 @@ with Core; with Envs; with Err; with Eval_Cb; +with Garbage_Collected; with Printer; with Reader; with Readline; -with Types.Atoms; -with Types.Builtins; with Types.Fns; with Types.Mal; with Types.Maps; @@ -18,11 +17,7 @@ with Types.Symbols.Names; procedure Step5_Tco is - Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1"); - Dbgenv0 : constant Boolean - := Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0"); - Dbgeval : constant Boolean - := Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval"); + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); use Types; use type Mal.T; @@ -36,7 +31,6 @@ procedure Step5_Tco is procedure Rep (Env : in Envs.Ptr) with Inline; - function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval); function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); procedure Exec (Script : in String; @@ -52,7 +46,7 @@ procedure Step5_Tco is -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. Ast : Mal.T := Ast0; - Env : Envs.Ptr := Env0.Copy_Pointer; + Env : Envs.Ptr := Env0; First : Mal.T; begin <> @@ -60,88 +54,97 @@ procedure Step5_Tco is Ada.Text_IO.New_Line; Ada.Text_IO.Put ("EVAL: "); Print (Ast); - if Dbgenv0 then - Envs.Dump_Stack (Long => Dbgenv1); - end if; + Envs.Dump_Stack (Env.all); end if; + case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key | Kind_Macro | Kind_Function => return Ast; when Kind_Symbol => - return Env.Get (Ast.Symbol); + return Env.all.Get (Ast.Symbol); when Kind_Map => - return Eval_Map_Elts (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map.all, Env); when Kind_Vector => - return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); + declare + Len : constant Natural := Ast.Sequence.all.Length; + List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len); + begin + for I in 1 .. Len loop + List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env)); + end loop; + return (Kind_Vector, List); + end; when Kind_List => null; end case; -- Ast is a list. - if Ast.Sequence.Length = 0 then + if Ast.Sequence.all.Length = 0 then return Ast; end if; - First := Ast.Sequence (1); + First := Ast.Sequence.all (1); -- Special forms -- Ast is a non-empty list, First is its first element. case First.Kind is when Kind_Symbol => if First.Symbol = Symbols.Names.Def then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol, "parameter 1 must be a symbol"); - return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do - Env.Set (Ast.Sequence (2).Symbol, R); + return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do + Env.all.Set (Ast.Sequence.all (2).Symbol, R); end return; -- do is a built-in function, shortening this test cascade. elsif First.Symbol = Symbols.Names.Fn then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence, "parameter 1 must be a sequence"); - return Fns.New_Function (Params => Ast.Sequence (2).Sequence, - Ast => Ast.Sequence (3), - Env => Env.New_Closure); + return Fns.New_Function + (Params => Ast.Sequence.all (2).Sequence.all, + Ast => Ast.Sequence.all (3), + Env => Env); elsif First.Symbol = Symbols.Names.Mal_If then - Err.Check (Ast.Sequence.Length in 3 .. 4, + Err.Check (Ast.Sequence.all.Length in 3 .. 4, "expected 2 or 3 parameters"); declare - Test : constant Mal.T := Eval (Ast.Sequence (2), Env); + Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env); begin if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then - Ast := Ast.Sequence (3); + Ast := Ast.Sequence.all (3); goto Restart; - elsif Ast.Sequence.Length = 3 then + elsif Ast.Sequence.all.Length = 3 then return Mal.Nil; else - Ast := Ast.Sequence (4); + Ast := Ast.Sequence.all (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence, "parameter 1 must be a sequence"); declare - Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence; + Bindings : constant Mal.Sequence_Ptr + := Ast.Sequence.all (2).Sequence; begin - Err.Check (Bindings.Length mod 2 = 0, + Err.Check (Bindings.all.Length mod 2 = 0, "parameter 1 must have an even length"); - Env.Replace_With_Sub; - for I in 1 .. Bindings.Length / 2 loop - Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol, + Env := Envs.New_Env (Outer => Env); + for I in 1 .. Bindings.all.Length / 2 loop + Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol, "binding keys must be symbols"); - Env.Set (Bindings (2 * I - 1).Symbol, - Eval (Bindings (2 * I), Env)); + Env.all.Set (Bindings.all (2 * I - 1).Symbol, + Eval (Bindings.all (2 * I), Env)); end loop; - Ast := Ast.Sequence (3); + Ast := Ast.Sequence.all (3); goto Restart; end; else -- Equivalent to First := Eval (First, Env) -- except that we already know enough to spare a recursive call. - First := Env.Get (First.Symbol); + First := Env.all.Get (First.Symbol); end if; when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key | Kind_Macro | Kind_Function => @@ -160,24 +163,24 @@ procedure Step5_Tco is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.Sequence.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.all.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.Sequence (I), Env); + Args (I) := Eval (Ast.Sequence.all (I), Env); end loop; return First.Builtin.all (Args); end; when Kind_Fn => declare - Args : Mal.T_Array (2 .. Ast.Sequence.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.all.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.Sequence (I), Env); + Args (I) := Eval (Ast.Sequence.all (I), Env); end loop; - Env.Replace_With_Sub (Outer => First.Fn.Env, - Binds => First.Fn.Params, - Exprs => Args); - Ast := First.Fn.Ast; + Env := Envs.New_Env (Outer => First.Fn.all.Env, + Binds => First.Fn.all.Params, + Exprs => Args); + Ast := First.Fn.all.Ast; goto Restart; end; when others => @@ -219,14 +222,15 @@ procedure Step5_Tco is Startup : constant String := "(def! not (fn* (a) (if a false true)))"; - Repl : Envs.Ptr renames Envs.Repl; + Repl : constant Envs.Ptr := Envs.New_Env; begin -- Show the Eval function to other packages. Eval_Cb.Cb := Eval'Unrestricted_Access; -- Add Core functions into the top environment. - Core.NS_Add_To_Repl; + Core.NS_Add_To_Repl (Repl); -- Native startup procedure. Exec (Startup, Repl); + -- Execute user commands. loop begin Rep (Repl); @@ -237,15 +241,16 @@ begin Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Mal.Nil; + Repl.all.Keep; + Garbage_Collected.Clean; end loop; Ada.Text_IO.New_Line; + -- If assertions are enabled, check deallocations. - Err.Data := Mal.Nil; -- Remove references to other packages - pragma Debug (Envs.Clear_And_Check_Allocations); - pragma Debug (Atoms.Check_Allocations); - pragma Debug (Builtins.Check_Allocations); - pragma Debug (Fns.Check_Allocations); - pragma Debug (Maps.Check_Allocations); - pragma Debug (Sequences.Check_Allocations); - pragma Debug (Symbols.Check_Allocations); + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; + Symbols.Check_Allocations; end Step5_Tco; diff --git a/ada.2/step6_file.adb b/ada.2/step6_file.adb index 5dc14d5e..9215bec2 100644 --- a/ada.2/step6_file.adb +++ b/ada.2/step6_file.adb @@ -7,11 +7,10 @@ with Core; with Envs; with Err; with Eval_Cb; +with Garbage_Collected; with Printer; with Reader; with Readline; -with Types.Atoms; -with Types.Builtins; with Types.Fns; with Types.Mal; with Types.Maps; @@ -20,26 +19,24 @@ with Types.Symbols.Names; procedure Step6_File is - Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1"); - Dbgenv0 : constant Boolean - := Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0"); - Dbgeval : constant Boolean - := Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval"); + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); use Types; use type Mal.T; + package ACL renames Ada.Command_Line; package ASU renames Ada.Strings.Unbounded; function Read return Mal.T_Array with Inline; function Eval (Ast0 : in Mal.T; Env0 : in Envs.Ptr) return Mal.T; + function Eval_Builtin (Args : in Mal.T_Array) return Mal.T; + -- The built-in variant needs to see the Repl variable. procedure Print (Ast : in Mal.T) with Inline; procedure Rep (Env : in Envs.Ptr) with Inline; - function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval); function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); procedure Exec (Script : in String; @@ -55,7 +52,7 @@ procedure Step6_File is -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. Ast : Mal.T := Ast0; - Env : Envs.Ptr := Env0.Copy_Pointer; + Env : Envs.Ptr := Env0; First : Mal.T; begin <> @@ -63,88 +60,97 @@ procedure Step6_File is Ada.Text_IO.New_Line; Ada.Text_IO.Put ("EVAL: "); Print (Ast); - if Dbgenv0 then - Envs.Dump_Stack (Long => Dbgenv1); - end if; + Envs.Dump_Stack (Env.all); end if; + case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key | Kind_Macro | Kind_Function => return Ast; when Kind_Symbol => - return Env.Get (Ast.Symbol); + return Env.all.Get (Ast.Symbol); when Kind_Map => - return Eval_Map_Elts (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map.all, Env); when Kind_Vector => - return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); + declare + Len : constant Natural := Ast.Sequence.all.Length; + List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len); + begin + for I in 1 .. Len loop + List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env)); + end loop; + return (Kind_Vector, List); + end; when Kind_List => null; end case; -- Ast is a list. - if Ast.Sequence.Length = 0 then + if Ast.Sequence.all.Length = 0 then return Ast; end if; - First := Ast.Sequence (1); + First := Ast.Sequence.all (1); -- Special forms -- Ast is a non-empty list, First is its first element. case First.Kind is when Kind_Symbol => if First.Symbol = Symbols.Names.Def then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol, "parameter 1 must be a symbol"); - return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do - Env.Set (Ast.Sequence (2).Symbol, R); + return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do + Env.all.Set (Ast.Sequence.all (2).Symbol, R); end return; -- do is a built-in function, shortening this test cascade. elsif First.Symbol = Symbols.Names.Fn then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence, "parameter 1 must be a sequence"); - return Fns.New_Function (Params => Ast.Sequence (2).Sequence, - Ast => Ast.Sequence (3), - Env => Env.New_Closure); + return Fns.New_Function + (Params => Ast.Sequence.all (2).Sequence.all, + Ast => Ast.Sequence.all (3), + Env => Env); elsif First.Symbol = Symbols.Names.Mal_If then - Err.Check (Ast.Sequence.Length in 3 .. 4, + Err.Check (Ast.Sequence.all.Length in 3 .. 4, "expected 2 or 3 parameters"); declare - Test : constant Mal.T := Eval (Ast.Sequence (2), Env); + Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env); begin if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then - Ast := Ast.Sequence (3); + Ast := Ast.Sequence.all (3); goto Restart; - elsif Ast.Sequence.Length = 3 then + elsif Ast.Sequence.all.Length = 3 then return Mal.Nil; else - Ast := Ast.Sequence (4); + Ast := Ast.Sequence.all (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence, "parameter 1 must be a sequence"); declare - Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence; + Bindings : constant Mal.Sequence_Ptr + := Ast.Sequence.all (2).Sequence; begin - Err.Check (Bindings.Length mod 2 = 0, + Err.Check (Bindings.all.Length mod 2 = 0, "parameter 1 must have an even length"); - Env.Replace_With_Sub; - for I in 1 .. Bindings.Length / 2 loop - Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol, + Env := Envs.New_Env (Outer => Env); + for I in 1 .. Bindings.all.Length / 2 loop + Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol, "binding keys must be symbols"); - Env.Set (Bindings (2 * I - 1).Symbol, - Eval (Bindings (2 * I), Env)); + Env.all.Set (Bindings.all (2 * I - 1).Symbol, + Eval (Bindings.all (2 * I), Env)); end loop; - Ast := Ast.Sequence (3); + Ast := Ast.Sequence.all (3); goto Restart; end; else -- Equivalent to First := Eval (First, Env) -- except that we already know enough to spare a recursive call. - First := Env.Get (First.Symbol); + First := Env.all.Get (First.Symbol); end if; when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key | Kind_Macro | Kind_Function => @@ -163,24 +169,24 @@ procedure Step6_File is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.Sequence.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.all.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.Sequence (I), Env); + Args (I) := Eval (Ast.Sequence.all (I), Env); end loop; return First.Builtin.all (Args); end; when Kind_Fn => declare - Args : Mal.T_Array (2 .. Ast.Sequence.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.all.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.Sequence (I), Env); + Args (I) := Eval (Ast.Sequence.all (I), Env); end loop; - Env.Replace_With_Sub (Outer => First.Fn.Env, - Binds => First.Fn.Params, - Exprs => Args); - Ast := First.Fn.Ast; + Env := Envs.New_Env (Outer => First.Fn.all.Env, + Binds => First.Fn.all.Params, + Exprs => Args); + Ast := First.Fn.all.Ast; goto Restart; end; when others => @@ -224,27 +230,37 @@ procedure Step6_File is := "(def! not (fn* (a) (if a false true)))" & "(def! load-file (fn* (f)" & " (eval (read-string (str ""(do "" (slurp f) "")"")))))"; - Repl : Envs.Ptr renames Envs.Repl; + Repl : constant Envs.Ptr := Envs.New_Env; + function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return Eval_Cb.Cb.all (Args (Args'First), Repl); + end Eval_Builtin; + Script : constant Boolean := 0 < ACL.Argument_Count; + Argv : Mal.Sequence_Ptr; begin -- Show the Eval function to other packages. Eval_Cb.Cb := Eval'Unrestricted_Access; -- Add Core functions into the top environment. - Core.NS_Add_To_Repl; + Core.NS_Add_To_Repl (Repl); + Repl.all.Set (Symbols.Constructor ("eval"), + (Kind_Builtin, Eval_Builtin'Unrestricted_Access)); -- Native startup procedure. Exec (Startup, Repl); -- Define ARGV from command line arguments. - declare - use Ada.Command_Line; - Args : Mal.T_Array (2 .. Argument_Count); - begin - for I in Args'Range loop - Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I))); + if Script then + Argv := Sequences.Constructor (ACL.Argument_Count - 1); + for I in 2 .. ACL.Argument_Count loop + Argv.all.Replace_Element + (I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I)))); end loop; - Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args)); - end; - -- Script? - if 0 < Ada.Command_Line.Argument_Count then - Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl); + else + Argv := Sequences.Constructor (0); + end if; + Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv)); + -- Execute user commands. + if Script then + Exec ("(load-file """ & ACL.Argument (1) & """)", Repl); else loop begin @@ -256,16 +272,17 @@ begin Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Mal.Nil; + Repl.all.Keep; + Garbage_Collected.Clean; end loop; Ada.Text_IO.New_Line; end if; + -- If assertions are enabled, check deallocations. - Err.Data := Mal.Nil; -- Remove references to other packages - pragma Debug (Envs.Clear_And_Check_Allocations); - pragma Debug (Atoms.Check_Allocations); - pragma Debug (Builtins.Check_Allocations); - pragma Debug (Fns.Check_Allocations); - pragma Debug (Maps.Check_Allocations); - pragma Debug (Sequences.Check_Allocations); - pragma Debug (Symbols.Check_Allocations); + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; + Symbols.Check_Allocations; end Step6_File; diff --git a/ada.2/step7_quote.adb b/ada.2/step7_quote.adb index 73652909..b4fe5983 100644 --- a/ada.2/step7_quote.adb +++ b/ada.2/step7_quote.adb @@ -1,4 +1,5 @@ with Ada.Command_Line; +with Ada.Containers.Vectors; with Ada.Environment_Variables; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; @@ -7,11 +8,10 @@ with Core; with Envs; with Err; with Eval_Cb; +with Garbage_Collected; with Printer; with Reader; with Readline; -with Types.Atoms; -with Types.Builtins; with Types.Fns; with Types.Mal; with Types.Maps; @@ -20,20 +20,19 @@ with Types.Symbols.Names; procedure Step7_Quote is - Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1"); - Dbgenv0 : constant Boolean - := Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0"); - Dbgeval : constant Boolean - := Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval"); + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); use Types; use type Mal.T; + package ACL renames Ada.Command_Line; package ASU renames Ada.Strings.Unbounded; function Read return Mal.T_Array with Inline; function Eval (Ast0 : in Mal.T; Env0 : in Envs.Ptr) return Mal.T; + function Eval_Builtin (Args : in Mal.T_Array) return Mal.T; + -- The built-in variant needs to see the Repl variable. function Quasiquote (Ast : in Mal.T; Env : in Envs.Ptr) return Mal.T; @@ -46,7 +45,6 @@ procedure Step7_Quote is procedure Rep (Env : in Envs.Ptr) with Inline; - function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval); function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); procedure Exec (Script : in String; @@ -62,7 +60,7 @@ procedure Step7_Quote is -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. Ast : Mal.T := Ast0; - Env : Envs.Ptr := Env0.Copy_Pointer; + Env : Envs.Ptr := Env0; First : Mal.T; begin <> @@ -70,94 +68,103 @@ procedure Step7_Quote is Ada.Text_IO.New_Line; Ada.Text_IO.Put ("EVAL: "); Print (Ast); - if Dbgenv0 then - Envs.Dump_Stack (Long => Dbgenv1); - end if; + Envs.Dump_Stack (Env.all); end if; + case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key | Kind_Macro | Kind_Function => return Ast; when Kind_Symbol => - return Env.Get (Ast.Symbol); + return Env.all.Get (Ast.Symbol); when Kind_Map => - return Eval_Map_Elts (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map.all, Env); when Kind_Vector => - return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); + declare + Len : constant Natural := Ast.Sequence.all.Length; + List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len); + begin + for I in 1 .. Len loop + List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env)); + end loop; + return (Kind_Vector, List); + end; when Kind_List => null; end case; -- Ast is a list. - if Ast.Sequence.Length = 0 then + if Ast.Sequence.all.Length = 0 then return Ast; end if; - First := Ast.Sequence (1); + First := Ast.Sequence.all (1); -- Special forms -- Ast is a non-empty list, First is its first element. case First.Kind is when Kind_Symbol => if First.Symbol = Symbols.Names.Def then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol, "parameter 1 must be a symbol"); - return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do - Env.Set (Ast.Sequence (2).Symbol, R); + return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do + Env.all.Set (Ast.Sequence.all (2).Symbol, R); end return; -- do is a built-in function, shortening this test cascade. elsif First.Symbol = Symbols.Names.Fn then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence, "parameter 1 must be a sequence"); - return Fns.New_Function (Params => Ast.Sequence (2).Sequence, - Ast => Ast.Sequence (3), - Env => Env.New_Closure); + return Fns.New_Function + (Params => Ast.Sequence.all (2).Sequence.all, + Ast => Ast.Sequence.all (3), + Env => Env); elsif First.Symbol = Symbols.Names.Mal_If then - Err.Check (Ast.Sequence.Length in 3 .. 4, + Err.Check (Ast.Sequence.all.Length in 3 .. 4, "expected 2 or 3 parameters"); declare - Test : constant Mal.T := Eval (Ast.Sequence (2), Env); + Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env); begin if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then - Ast := Ast.Sequence (3); + Ast := Ast.Sequence.all (3); goto Restart; - elsif Ast.Sequence.Length = 3 then + elsif Ast.Sequence.all.Length = 3 then return Mal.Nil; else - Ast := Ast.Sequence (4); + Ast := Ast.Sequence.all (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence, "parameter 1 must be a sequence"); declare - Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence; + Bindings : constant Mal.Sequence_Ptr + := Ast.Sequence.all (2).Sequence; begin - Err.Check (Bindings.Length mod 2 = 0, + Err.Check (Bindings.all.Length mod 2 = 0, "parameter 1 must have an even length"); - Env.Replace_With_Sub; - for I in 1 .. Bindings.Length / 2 loop - Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol, + Env := Envs.New_Env (Outer => Env); + for I in 1 .. Bindings.all.Length / 2 loop + Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol, "binding keys must be symbols"); - Env.Set (Bindings (2 * I - 1).Symbol, - Eval (Bindings (2 * I), Env)); + Env.all.Set (Bindings.all (2 * I - 1).Symbol, + Eval (Bindings.all (2 * I), Env)); end loop; - Ast := Ast.Sequence (3); + Ast := Ast.Sequence.all (3); goto Restart; end; elsif First.Symbol = Symbols.Names.Quasiquote then - Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); - return Quasiquote (Ast.Sequence (2), Env); + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Quasiquote (Ast.Sequence.all (2), Env); elsif First.Symbol = Symbols.Names.Quote then - Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); - return Ast.Sequence (2); + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Ast.Sequence.all (2); else -- Equivalent to First := Eval (First, Env) -- except that we already know enough to spare a recursive call. - First := Env.Get (First.Symbol); + First := Env.all.Get (First.Symbol); end if; when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key | Kind_Macro | Kind_Function => @@ -176,24 +183,24 @@ procedure Step7_Quote is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.Sequence.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.all.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.Sequence (I), Env); + Args (I) := Eval (Ast.Sequence.all (I), Env); end loop; return First.Builtin.all (Args); end; when Kind_Fn => declare - Args : Mal.T_Array (2 .. Ast.Sequence.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.all.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.Sequence (I), Env); + Args (I) := Eval (Ast.Sequence.all (I), Env); end loop; - Env.Replace_With_Sub (Outer => First.Fn.Env, - Binds => First.Fn.Params, - Exprs => Args); - Ast := First.Fn.Ast; + Env := Envs.New_Env (Outer => First.Fn.all.Env, + Binds => First.Fn.all.Params, + Exprs => Args); + Ast := First.Fn.all.Ast; goto Restart; end; when others => @@ -225,46 +232,56 @@ procedure Step7_Quote is Env : in Envs.Ptr) return Mal.T is - function Quasiquote_List (List : in Sequences.Ptr) return Mal.T + function Quasiquote_List (List : in Sequences.Instance) return Mal.T with Inline; -- Handle vectors and lists not starting with unquote. - function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is - -- The final return concatenates these lists. - R : Mal.T_Array (1 .. List.Length); + function Quasiquote_List (List : in Sequences.Instance) return Mal.T is + package Vectors is new Ada.Containers.Vectors (Positive, Mal.T); + Vector : Vectors.Vector; -- buffer for concatenation + Sequence : Mal.Sequence_Ptr; + Tmp : Mal.T; begin - for I in R'Range loop - R (I) := List (I); - if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length - and then R (I).Sequence (1) = (Kind_Symbol, - Symbols.Names.Splice_Unquote) + for I in 1 .. List.Length loop + if List (I).Kind in Kind_List + and then 0 < List (I).Sequence.all.Length + and then List (I).Sequence.all (1) + = (Kind_Symbol, Symbols.Names.Splice_Unquote) then - Err.Check (R (I).Sequence.Length = 2, + Err.Check (List (I).Sequence.all.Length = 2, "splice-unquote expects 1 parameter"); - R (I) := Eval (@.Sequence (2), Env); - Err.Check (R (I).Kind = Kind_List, + Tmp := Eval (List (I).Sequence.all (2), Env); + Err.Check (Tmp.Kind = Kind_List, "splice_unquote expects a list"); + for I in 1 .. Tmp.Sequence.all.Length loop + Vector.Append (Tmp.Sequence.all (I)); + end loop; else - R (I) := Sequences.List - (Mal.T_Array'(1 => Quasiquote (@, Env))); + Vector.Append (Quasiquote (List (I), Env)); end if; end loop; - return Sequences.Concat (R); + -- Now that we know the number of elements, convert to a list. + Sequence := Sequences.Constructor (Natural (Vector.Length)); + for I in 1 .. Natural (Vector.Length) loop + Sequence.Replace_Element (I, Vector (I)); + end loop; + return (Kind_List, Sequence); end Quasiquote_List; begin -- Quasiquote case Ast.Kind is when Kind_Vector => -- When the test is updated, replace Kind_List with Kind_Vector. - return Quasiquote_List (Ast.Sequence); + return Quasiquote_List (Ast.Sequence.all); when Kind_List => - if 0 < Ast.Sequence.Length - and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote) + if 0 < Ast.Sequence.all.Length + and then Ast.Sequence.all (1) = (Kind_Symbol, + Symbols.Names.Unquote) then - Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); - return Eval (Ast.Sequence (2), Env); + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Eval (Ast.Sequence.all (2), Env); else - return Quasiquote_List (Ast.Sequence); + return Quasiquote_List (Ast.Sequence.all); end if; when others => return Ast; @@ -291,27 +308,37 @@ procedure Step7_Quote is := "(def! not (fn* (a) (if a false true)))" & "(def! load-file (fn* (f)" & " (eval (read-string (str ""(do "" (slurp f) "")"")))))"; - Repl : Envs.Ptr renames Envs.Repl; + Repl : constant Envs.Ptr := Envs.New_Env; + function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return Eval_Cb.Cb.all (Args (Args'First), Repl); + end Eval_Builtin; + Script : constant Boolean := 0 < ACL.Argument_Count; + Argv : Mal.Sequence_Ptr; begin -- Show the Eval function to other packages. Eval_Cb.Cb := Eval'Unrestricted_Access; -- Add Core functions into the top environment. - Core.NS_Add_To_Repl; + Core.NS_Add_To_Repl (Repl); + Repl.all.Set (Symbols.Constructor ("eval"), + (Kind_Builtin, Eval_Builtin'Unrestricted_Access)); -- Native startup procedure. Exec (Startup, Repl); -- Define ARGV from command line arguments. - declare - use Ada.Command_Line; - Args : Mal.T_Array (2 .. Argument_Count); - begin - for I in Args'Range loop - Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I))); + if Script then + Argv := Sequences.Constructor (ACL.Argument_Count - 1); + for I in 2 .. ACL.Argument_Count loop + Argv.all.Replace_Element + (I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I)))); end loop; - Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args)); - end; - -- Script? - if 0 < Ada.Command_Line.Argument_Count then - Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl); + else + Argv := Sequences.Constructor (0); + end if; + Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv)); + -- Execute user commands. + if Script then + Exec ("(load-file """ & ACL.Argument (1) & """)", Repl); else loop begin @@ -323,16 +350,17 @@ begin Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Mal.Nil; + Repl.all.Keep; + Garbage_Collected.Clean; end loop; Ada.Text_IO.New_Line; end if; + -- If assertions are enabled, check deallocations. - Err.Data := Mal.Nil; -- Remove references to other packages - pragma Debug (Envs.Clear_And_Check_Allocations); - pragma Debug (Atoms.Check_Allocations); - pragma Debug (Builtins.Check_Allocations); - pragma Debug (Fns.Check_Allocations); - pragma Debug (Maps.Check_Allocations); - pragma Debug (Sequences.Check_Allocations); - pragma Debug (Symbols.Check_Allocations); + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; + Symbols.Check_Allocations; end Step7_Quote; diff --git a/ada.2/step8_macros.adb b/ada.2/step8_macros.adb index b8b9dc9a..81309218 100644 --- a/ada.2/step8_macros.adb +++ b/ada.2/step8_macros.adb @@ -1,4 +1,5 @@ with Ada.Command_Line; +with Ada.Containers.Vectors; with Ada.Environment_Variables; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; @@ -7,11 +8,10 @@ with Core; with Envs; with Err; with Eval_Cb; +with Garbage_Collected; with Printer; with Reader; with Readline; -with Types.Atoms; -with Types.Builtins; with Types.Fns; with Types.Mal; with Types.Maps; @@ -20,20 +20,19 @@ with Types.Symbols.Names; procedure Step8_Macros is - Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1"); - Dbgenv0 : constant Boolean - := Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0"); - Dbgeval : constant Boolean - := Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval"); + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); use Types; use type Mal.T; + package ACL renames Ada.Command_Line; package ASU renames Ada.Strings.Unbounded; function Read return Mal.T_Array with Inline; function Eval (Ast0 : in Mal.T; Env0 : in Envs.Ptr) return Mal.T; + function Eval_Builtin (Args : in Mal.T_Array) return Mal.T; + -- The built-in variant needs to see the Repl variable. function Quasiquote (Ast : in Mal.T; Env : in Envs.Ptr) return Mal.T; @@ -46,7 +45,6 @@ procedure Step8_Macros is procedure Rep (Env : in Envs.Ptr) with Inline; - function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval); function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); procedure Exec (Script : in String; @@ -62,7 +60,7 @@ procedure Step8_Macros is -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. Ast : Mal.T := Ast0; - Env : Envs.Ptr := Env0.Copy_Pointer; + Env : Envs.Ptr := Env0; Macroexpanding : Boolean := False; First : Mal.T; begin @@ -71,111 +69,120 @@ procedure Step8_Macros is Ada.Text_IO.New_Line; Ada.Text_IO.Put ("EVAL: "); Print (Ast); - if Dbgenv0 then - Envs.Dump_Stack (Long => Dbgenv1); - end if; + Envs.Dump_Stack (Env.all); end if; + case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key | Kind_Macro | Kind_Function => return Ast; when Kind_Symbol => - return Env.Get (Ast.Symbol); + return Env.all.Get (Ast.Symbol); when Kind_Map => - return Eval_Map_Elts (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map.all, Env); when Kind_Vector => - return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); + declare + Len : constant Natural := Ast.Sequence.all.Length; + List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len); + begin + for I in 1 .. Len loop + List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env)); + end loop; + return (Kind_Vector, List); + end; when Kind_List => null; end case; -- Ast is a list. - if Ast.Sequence.Length = 0 then + if Ast.Sequence.all.Length = 0 then return Ast; end if; - First := Ast.Sequence (1); + First := Ast.Sequence.all (1); -- Special forms -- Ast is a non-empty list, First is its first element. case First.Kind is when Kind_Symbol => if First.Symbol = Symbols.Names.Def then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol, "parameter 1 must be a symbol"); - return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do - Env.Set (Ast.Sequence (2).Symbol, R); + return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do + Env.all.Set (Ast.Sequence.all (2).Symbol, R); end return; elsif First.Symbol = Symbols.Names.Defmacro then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol, "parameter 1 must be a symbol"); declare - F : constant Mal.T := Eval (Ast.Sequence (3), Env); + F : constant Mal.T := Eval (Ast.Sequence.all (3), Env); begin Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function"); - return R : constant Mal.T := F.Fn.New_Macro do - Env.Set (Ast.Sequence (2).Symbol, R); + return R : constant Mal.T := F.Fn.all.New_Macro do + Env.all.Set (Ast.Sequence.all (2).Symbol, R); end return; end; -- do is a built-in function, shortening this test cascade. elsif First.Symbol = Symbols.Names.Fn then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence, "parameter 1 must be a sequence"); - return Fns.New_Function (Params => Ast.Sequence (2).Sequence, - Ast => Ast.Sequence (3), - Env => Env.New_Closure); + return Fns.New_Function + (Params => Ast.Sequence.all (2).Sequence.all, + Ast => Ast.Sequence.all (3), + Env => Env); elsif First.Symbol = Symbols.Names.Mal_If then - Err.Check (Ast.Sequence.Length in 3 .. 4, + Err.Check (Ast.Sequence.all.Length in 3 .. 4, "expected 2 or 3 parameters"); declare - Test : constant Mal.T := Eval (Ast.Sequence (2), Env); + Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env); begin if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then - Ast := Ast.Sequence (3); + Ast := Ast.Sequence.all (3); goto Restart; - elsif Ast.Sequence.Length = 3 then + elsif Ast.Sequence.all.Length = 3 then return Mal.Nil; else - Ast := Ast.Sequence (4); + Ast := Ast.Sequence.all (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence, "parameter 1 must be a sequence"); declare - Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence; + Bindings : constant Mal.Sequence_Ptr + := Ast.Sequence.all (2).Sequence; begin - Err.Check (Bindings.Length mod 2 = 0, + Err.Check (Bindings.all.Length mod 2 = 0, "parameter 1 must have an even length"); - Env.Replace_With_Sub; - for I in 1 .. Bindings.Length / 2 loop - Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol, + Env := Envs.New_Env (Outer => Env); + for I in 1 .. Bindings.all.Length / 2 loop + Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol, "binding keys must be symbols"); - Env.Set (Bindings (2 * I - 1).Symbol, - Eval (Bindings (2 * I), Env)); + Env.all.Set (Bindings.all (2 * I - 1).Symbol, + Eval (Bindings.all (2 * I), Env)); end loop; - Ast := Ast.Sequence (3); + Ast := Ast.Sequence.all (3); goto Restart; end; elsif First.Symbol = Symbols.Names.Macroexpand then - Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); Macroexpanding := True; - Ast := Ast.Sequence (2); + Ast := Ast.Sequence.all (2); goto Restart; elsif First.Symbol = Symbols.Names.Quasiquote then - Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); - return Quasiquote (Ast.Sequence (2), Env); + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Quasiquote (Ast.Sequence.all (2), Env); elsif First.Symbol = Symbols.Names.Quote then - Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); - return Ast.Sequence (2); + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Ast.Sequence.all (2); else -- Equivalent to First := Eval (First, Env) -- except that we already know enough to spare a recursive call. - First := Env.Get (First.Symbol); + First := Env.all.Get (First.Symbol); end if; when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key | Kind_Macro | Kind_Function => @@ -194,43 +201,44 @@ procedure Step8_Macros is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.Sequence.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.all.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.Sequence (I), Env); + Args (I) := Eval (Ast.Sequence.all (I), Env); end loop; return First.Builtin.all (Args); end; when Kind_Fn => declare - Args : Mal.T_Array (2 .. Ast.Sequence.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.all.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.Sequence (I), Env); + Args (I) := Eval (Ast.Sequence.all (I), Env); end loop; - Env.Replace_With_Sub (Outer => First.Fn.Env, - Binds => First.Fn.Params, - Exprs => Args); - Ast := First.Fn.Ast; + Env := Envs.New_Env (Outer => First.Fn.all.Env, + Binds => First.Fn.all.Params, + Exprs => Args); + Ast := First.Fn.all.Ast; goto Restart; end; when Kind_Macro => declare Args : constant Mal.T_Array - := Ast.Sequence.Tail (Ast.Sequence.Length - 1); + := Ast.Sequence.all.Tail (Ast.Sequence.all.Length - 1); begin if Macroexpanding then -- Evaluate the macro with tail call optimization. - Env.Replace_With_Sub (Binds => First.Fn.Params, - Exprs => Args); - Ast := First.Fn.Ast; + Env := Envs.New_Env (Outer => Env, + Binds => First.Fn.all.Params, + Exprs => Args); + Ast := First.Fn.all.Ast; goto Restart; else -- Evaluate the macro normally. - Ast := Eval (First.Fn.Ast, Envs.Sub - (Outer => Env, - Binds => First.Fn.Params, - Exprs => Args)); + Ast := Eval (First.Fn.all.Ast, + Envs.New_Env (Outer => Env, + Binds => First.Fn.all.Params, + Exprs => Args)); -- Then evaluate the result with TCO. goto Restart; end if; @@ -268,46 +276,56 @@ procedure Step8_Macros is Env : in Envs.Ptr) return Mal.T is - function Quasiquote_List (List : in Sequences.Ptr) return Mal.T + function Quasiquote_List (List : in Sequences.Instance) return Mal.T with Inline; -- Handle vectors and lists not starting with unquote. - function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is - -- The final return concatenates these lists. - R : Mal.T_Array (1 .. List.Length); + function Quasiquote_List (List : in Sequences.Instance) return Mal.T is + package Vectors is new Ada.Containers.Vectors (Positive, Mal.T); + Vector : Vectors.Vector; -- buffer for concatenation + Sequence : Mal.Sequence_Ptr; + Tmp : Mal.T; begin - for I in R'Range loop - R (I) := List (I); - if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length - and then R (I).Sequence (1) = (Kind_Symbol, - Symbols.Names.Splice_Unquote) + for I in 1 .. List.Length loop + if List (I).Kind in Kind_List + and then 0 < List (I).Sequence.all.Length + and then List (I).Sequence.all (1) + = (Kind_Symbol, Symbols.Names.Splice_Unquote) then - Err.Check (R (I).Sequence.Length = 2, + Err.Check (List (I).Sequence.all.Length = 2, "splice-unquote expects 1 parameter"); - R (I) := Eval (@.Sequence (2), Env); - Err.Check (R (I).Kind = Kind_List, + Tmp := Eval (List (I).Sequence.all (2), Env); + Err.Check (Tmp.Kind = Kind_List, "splice_unquote expects a list"); + for I in 1 .. Tmp.Sequence.all.Length loop + Vector.Append (Tmp.Sequence.all (I)); + end loop; else - R (I) := Sequences.List - (Mal.T_Array'(1 => Quasiquote (@, Env))); + Vector.Append (Quasiquote (List (I), Env)); end if; end loop; - return Sequences.Concat (R); + -- Now that we know the number of elements, convert to a list. + Sequence := Sequences.Constructor (Natural (Vector.Length)); + for I in 1 .. Natural (Vector.Length) loop + Sequence.Replace_Element (I, Vector (I)); + end loop; + return (Kind_List, Sequence); end Quasiquote_List; begin -- Quasiquote case Ast.Kind is when Kind_Vector => -- When the test is updated, replace Kind_List with Kind_Vector. - return Quasiquote_List (Ast.Sequence); + return Quasiquote_List (Ast.Sequence.all); when Kind_List => - if 0 < Ast.Sequence.Length - and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote) + if 0 < Ast.Sequence.all.Length + and then Ast.Sequence.all (1) = (Kind_Symbol, + Symbols.Names.Unquote) then - Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); - return Eval (Ast.Sequence (2), Env); + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Eval (Ast.Sequence.all (2), Env); else - return Quasiquote_List (Ast.Sequence); + return Quasiquote_List (Ast.Sequence.all); end if; when others => return Ast; @@ -345,27 +363,37 @@ procedure Step8_Macros is & " (if (= 1 (count xs)) (first xs)" & " `(let* (or_FIXME ~(first xs))" & " (if or_FIXME or_FIXME (or ~@(rest xs))))))))"; - Repl : Envs.Ptr renames Envs.Repl; + Repl : constant Envs.Ptr := Envs.New_Env; + function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return Eval_Cb.Cb.all (Args (Args'First), Repl); + end Eval_Builtin; + Script : constant Boolean := 0 < ACL.Argument_Count; + Argv : Mal.Sequence_Ptr; begin -- Show the Eval function to other packages. Eval_Cb.Cb := Eval'Unrestricted_Access; -- Add Core functions into the top environment. - Core.NS_Add_To_Repl; + Core.NS_Add_To_Repl (Repl); + Repl.all.Set (Symbols.Constructor ("eval"), + (Kind_Builtin, Eval_Builtin'Unrestricted_Access)); -- Native startup procedure. Exec (Startup, Repl); -- Define ARGV from command line arguments. - declare - use Ada.Command_Line; - Args : Mal.T_Array (2 .. Argument_Count); - begin - for I in Args'Range loop - Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I))); + if Script then + Argv := Sequences.Constructor (ACL.Argument_Count - 1); + for I in 2 .. ACL.Argument_Count loop + Argv.all.Replace_Element + (I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I)))); end loop; - Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args)); - end; - -- Script? - if 0 < Ada.Command_Line.Argument_Count then - Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl); + else + Argv := Sequences.Constructor (0); + end if; + Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv)); + -- Execute user commands. + if Script then + Exec ("(load-file """ & ACL.Argument (1) & """)", Repl); else loop begin @@ -377,16 +405,17 @@ begin Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Mal.Nil; + Repl.all.Keep; + Garbage_Collected.Clean; end loop; Ada.Text_IO.New_Line; end if; + -- If assertions are enabled, check deallocations. - Err.Data := Mal.Nil; -- Remove references to other packages - pragma Debug (Envs.Clear_And_Check_Allocations); - pragma Debug (Atoms.Check_Allocations); - pragma Debug (Builtins.Check_Allocations); - pragma Debug (Fns.Check_Allocations); - pragma Debug (Maps.Check_Allocations); - pragma Debug (Sequences.Check_Allocations); - pragma Debug (Symbols.Check_Allocations); + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; + Symbols.Check_Allocations; end Step8_Macros; diff --git a/ada.2/step9_try.adb b/ada.2/step9_try.adb index 9fc6cecc..a1739989 100644 --- a/ada.2/step9_try.adb +++ b/ada.2/step9_try.adb @@ -1,4 +1,5 @@ with Ada.Command_Line; +with Ada.Containers.Vectors; with Ada.Environment_Variables; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; @@ -7,11 +8,10 @@ with Core; with Envs; with Err; with Eval_Cb; +with Garbage_Collected; with Printer; with Reader; with Readline; -with Types.Atoms; -with Types.Builtins; with Types.Fns; with Types.Mal; with Types.Maps; @@ -20,20 +20,19 @@ with Types.Symbols.Names; procedure Step9_Try is - Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1"); - Dbgenv0 : constant Boolean - := Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0"); - Dbgeval : constant Boolean - := Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval"); + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); use Types; use type Mal.T; + package ACL renames Ada.Command_Line; package ASU renames Ada.Strings.Unbounded; function Read return Mal.T_Array with Inline; function Eval (Ast0 : in Mal.T; Env0 : in Envs.Ptr) return Mal.T; + function Eval_Builtin (Args : in Mal.T_Array) return Mal.T; + -- The built-in variant needs to see the Repl variable. function Quasiquote (Ast : in Mal.T; Env : in Envs.Ptr) return Mal.T; @@ -46,7 +45,6 @@ procedure Step9_Try is procedure Rep (Env : in Envs.Ptr) with Inline; - function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval); function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); procedure Exec (Script : in String; @@ -62,7 +60,7 @@ procedure Step9_Try is -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. Ast : Mal.T := Ast0; - Env : Envs.Ptr := Env0.Copy_Pointer; + Env : Envs.Ptr := Env0; Macroexpanding : Boolean := False; First : Mal.T; begin @@ -71,137 +69,149 @@ procedure Step9_Try is Ada.Text_IO.New_Line; Ada.Text_IO.Put ("EVAL: "); Print (Ast); - if Dbgenv0 then - Envs.Dump_Stack (Long => Dbgenv1); - end if; + Envs.Dump_Stack (Env.all); end if; + case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key | Kind_Macro | Kind_Function => return Ast; when Kind_Symbol => - return Env.Get (Ast.Symbol); + return Env.all.Get (Ast.Symbol); when Kind_Map => - return Eval_Map_Elts (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map.all, Env); when Kind_Vector => - return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); + declare + Len : constant Natural := Ast.Sequence.all.Length; + List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len); + begin + for I in 1 .. Len loop + List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env)); + end loop; + return (Kind_Vector, List); + end; when Kind_List => null; end case; -- Ast is a list. - if Ast.Sequence.Length = 0 then + if Ast.Sequence.all.Length = 0 then return Ast; end if; - First := Ast.Sequence (1); + First := Ast.Sequence.all (1); -- Special forms -- Ast is a non-empty list, First is its first element. case First.Kind is when Kind_Symbol => if First.Symbol = Symbols.Names.Def then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol, "parameter 1 must be a symbol"); - return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do - Env.Set (Ast.Sequence (2).Symbol, R); + return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do + Env.all.Set (Ast.Sequence.all (2).Symbol, R); end return; elsif First.Symbol = Symbols.Names.Defmacro then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol, "parameter 1 must be a symbol"); declare - F : constant Mal.T := Eval (Ast.Sequence (3), Env); + F : constant Mal.T := Eval (Ast.Sequence.all (3), Env); begin Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function"); - return R : constant Mal.T := F.Fn.New_Macro do - Env.Set (Ast.Sequence (2).Symbol, R); + return R : constant Mal.T := F.Fn.all.New_Macro do + Env.all.Set (Ast.Sequence.all (2).Symbol, R); end return; end; -- do is a built-in function, shortening this test cascade. elsif First.Symbol = Symbols.Names.Fn then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence, "parameter 1 must be a sequence"); - return Fns.New_Function (Params => Ast.Sequence (2).Sequence, - Ast => Ast.Sequence (3), - Env => Env.New_Closure); + return Fns.New_Function + (Params => Ast.Sequence.all (2).Sequence.all, + Ast => Ast.Sequence.all (3), + Env => Env); elsif First.Symbol = Symbols.Names.Mal_If then - Err.Check (Ast.Sequence.Length in 3 .. 4, + Err.Check (Ast.Sequence.all.Length in 3 .. 4, "expected 2 or 3 parameters"); declare - Test : constant Mal.T := Eval (Ast.Sequence (2), Env); + Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env); begin if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then - Ast := Ast.Sequence (3); + Ast := Ast.Sequence.all (3); goto Restart; - elsif Ast.Sequence.Length = 3 then + elsif Ast.Sequence.all.Length = 3 then return Mal.Nil; else - Ast := Ast.Sequence (4); + Ast := Ast.Sequence.all (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence, "parameter 1 must be a sequence"); declare - Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence; + Bindings : constant Mal.Sequence_Ptr + := Ast.Sequence.all (2).Sequence; begin - Err.Check (Bindings.Length mod 2 = 0, + Err.Check (Bindings.all.Length mod 2 = 0, "parameter 1 must have an even length"); - Env.Replace_With_Sub; - for I in 1 .. Bindings.Length / 2 loop - Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol, + Env := Envs.New_Env (Outer => Env); + for I in 1 .. Bindings.all.Length / 2 loop + Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol, "binding keys must be symbols"); - Env.Set (Bindings (2 * I - 1).Symbol, - Eval (Bindings (2 * I), Env)); + Env.all.Set (Bindings.all (2 * I - 1).Symbol, + Eval (Bindings.all (2 * I), Env)); end loop; - Ast := Ast.Sequence (3); + Ast := Ast.Sequence.all (3); goto Restart; end; elsif First.Symbol = Symbols.Names.Macroexpand then - Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); Macroexpanding := True; - Ast := Ast.Sequence (2); + Ast := Ast.Sequence.all (2); goto Restart; elsif First.Symbol = Symbols.Names.Quasiquote then - Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); - return Quasiquote (Ast.Sequence (2), Env); + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Quasiquote (Ast.Sequence.all (2), Env); elsif First.Symbol = Symbols.Names.Quote then - Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); - return Ast.Sequence (2); + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Ast.Sequence.all (2); elsif First.Symbol = Symbols.Names.Try then - if Ast.Sequence.Length = 2 then - Ast := Ast.Sequence (2); + if Ast.Sequence.all.Length = 2 then + Ast := Ast.Sequence.all (2); goto Restart; end if; - Err.Check (Ast.Sequence.Length = 3, "expected 1 or 2 parameters"); - Err.Check (Ast.Sequence (3).Kind = Kind_List, + Err.Check (Ast.Sequence.all.Length = 3, + "expected 1 or 2 parameters"); + Err.Check (Ast.Sequence.all (3).Kind = Kind_List, "parameter 2 must be a list"); declare - A3 : constant Sequences.Ptr := Ast.Sequence (3).Sequence; + A3 : constant Mal.Sequence_Ptr := Ast.Sequence.all (3).Sequence; begin - Err.Check (A3.Length = 3, "length of parameter 2 must be 3"); - Err.Check (A3 (1) = (Kind_Symbol, Symbols.Names.Catch), + Err.Check (A3.all.Length = 3, + "length of parameter 2 must be 3"); + Err.Check (A3.all (1) = (Kind_Symbol, Symbols.Names.Catch), "parameter 3 must start with 'catch*'"); - Err.Check (A3 (2).Kind = Kind_Symbol, + Err.Check (A3.all (2).Kind = Kind_Symbol, "a symbol must follow catch*"); begin - return Eval (Ast.Sequence (2), Env); + return Eval (Ast.Sequence.all (2), Env); exception - when Err.Error => - Env.Replace_With_Sub; - Env.Set (A3 (2).Symbol, Err.Data); - Ast := A3 (3); - goto Restart; + when Err.Error => + null; end; + Env := Envs.New_Env (Outer => Env); + Env.all.Set (A3.all (2).Symbol, Err.Data); + Ast := A3.all (3); + goto Restart; end; else -- Equivalent to First := Eval (First, Env) -- except that we already know enough to spare a recursive call. - First := Env.Get (First.Symbol); + First := Env.all.Get (First.Symbol); end if; when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key | Kind_Macro | Kind_Function => @@ -220,43 +230,44 @@ procedure Step9_Try is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.Sequence.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.all.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.Sequence (I), Env); + Args (I) := Eval (Ast.Sequence.all (I), Env); end loop; return First.Builtin.all (Args); end; when Kind_Fn => declare - Args : Mal.T_Array (2 .. Ast.Sequence.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.all.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.Sequence (I), Env); + Args (I) := Eval (Ast.Sequence.all (I), Env); end loop; - Env.Replace_With_Sub (Outer => First.Fn.Env, - Binds => First.Fn.Params, - Exprs => Args); - Ast := First.Fn.Ast; + Env := Envs.New_Env (Outer => First.Fn.all.Env, + Binds => First.Fn.all.Params, + Exprs => Args); + Ast := First.Fn.all.Ast; goto Restart; end; when Kind_Macro => declare Args : constant Mal.T_Array - := Ast.Sequence.Tail (Ast.Sequence.Length - 1); + := Ast.Sequence.all.Tail (Ast.Sequence.all.Length - 1); begin if Macroexpanding then -- Evaluate the macro with tail call optimization. - Env.Replace_With_Sub (Binds => First.Fn.Params, - Exprs => Args); - Ast := First.Fn.Ast; + Env := Envs.New_Env (Outer => Env, + Binds => First.Fn.all.Params, + Exprs => Args); + Ast := First.Fn.all.Ast; goto Restart; else -- Evaluate the macro normally. - Ast := Eval (First.Fn.Ast, Envs.Sub - (Outer => Env, - Binds => First.Fn.Params, - Exprs => Args)); + Ast := Eval (First.Fn.all.Ast, + Envs.New_Env (Outer => Env, + Binds => First.Fn.all.Params, + Exprs => Args)); -- Then evaluate the result with TCO. goto Restart; end if; @@ -294,46 +305,56 @@ procedure Step9_Try is Env : in Envs.Ptr) return Mal.T is - function Quasiquote_List (List : in Sequences.Ptr) return Mal.T + function Quasiquote_List (List : in Sequences.Instance) return Mal.T with Inline; -- Handle vectors and lists not starting with unquote. - function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is - -- The final return concatenates these lists. - R : Mal.T_Array (1 .. List.Length); + function Quasiquote_List (List : in Sequences.Instance) return Mal.T is + package Vectors is new Ada.Containers.Vectors (Positive, Mal.T); + Vector : Vectors.Vector; -- buffer for concatenation + Sequence : Mal.Sequence_Ptr; + Tmp : Mal.T; begin - for I in R'Range loop - R (I) := List (I); - if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length - and then R (I).Sequence (1) = (Kind_Symbol, - Symbols.Names.Splice_Unquote) + for I in 1 .. List.Length loop + if List (I).Kind in Kind_List + and then 0 < List (I).Sequence.all.Length + and then List (I).Sequence.all (1) + = (Kind_Symbol, Symbols.Names.Splice_Unquote) then - Err.Check (R (I).Sequence.Length = 2, + Err.Check (List (I).Sequence.all.Length = 2, "splice-unquote expects 1 parameter"); - R (I) := Eval (@.Sequence (2), Env); - Err.Check (R (I).Kind = Kind_List, + Tmp := Eval (List (I).Sequence.all (2), Env); + Err.Check (Tmp.Kind = Kind_List, "splice_unquote expects a list"); + for I in 1 .. Tmp.Sequence.all.Length loop + Vector.Append (Tmp.Sequence.all (I)); + end loop; else - R (I) := Sequences.List - (Mal.T_Array'(1 => Quasiquote (@, Env))); + Vector.Append (Quasiquote (List (I), Env)); end if; end loop; - return Sequences.Concat (R); + -- Now that we know the number of elements, convert to a list. + Sequence := Sequences.Constructor (Natural (Vector.Length)); + for I in 1 .. Natural (Vector.Length) loop + Sequence.Replace_Element (I, Vector (I)); + end loop; + return (Kind_List, Sequence); end Quasiquote_List; begin -- Quasiquote case Ast.Kind is when Kind_Vector => -- When the test is updated, replace Kind_List with Kind_Vector. - return Quasiquote_List (Ast.Sequence); + return Quasiquote_List (Ast.Sequence.all); when Kind_List => - if 0 < Ast.Sequence.Length - and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote) + if 0 < Ast.Sequence.all.Length + and then Ast.Sequence.all (1) = (Kind_Symbol, + Symbols.Names.Unquote) then - Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); - return Eval (Ast.Sequence (2), Env); + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Eval (Ast.Sequence.all (2), Env); else - return Quasiquote_List (Ast.Sequence); + return Quasiquote_List (Ast.Sequence.all); end if; when others => return Ast; @@ -371,27 +392,37 @@ procedure Step9_Try is & " (if (= 1 (count xs)) (first xs)" & " `(let* (or_FIXME ~(first xs))" & " (if or_FIXME or_FIXME (or ~@(rest xs))))))))"; - Repl : Envs.Ptr renames Envs.Repl; + Repl : constant Envs.Ptr := Envs.New_Env; + function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return Eval_Cb.Cb.all (Args (Args'First), Repl); + end Eval_Builtin; + Script : constant Boolean := 0 < ACL.Argument_Count; + Argv : Mal.Sequence_Ptr; begin -- Show the Eval function to other packages. Eval_Cb.Cb := Eval'Unrestricted_Access; -- Add Core functions into the top environment. - Core.NS_Add_To_Repl; + Core.NS_Add_To_Repl (Repl); + Repl.all.Set (Symbols.Constructor ("eval"), + (Kind_Builtin, Eval_Builtin'Unrestricted_Access)); -- Native startup procedure. Exec (Startup, Repl); -- Define ARGV from command line arguments. - declare - use Ada.Command_Line; - Args : Mal.T_Array (2 .. Argument_Count); - begin - for I in Args'Range loop - Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I))); + if Script then + Argv := Sequences.Constructor (ACL.Argument_Count - 1); + for I in 2 .. ACL.Argument_Count loop + Argv.all.Replace_Element + (I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I)))); end loop; - Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args)); - end; - -- Script? - if 0 < Ada.Command_Line.Argument_Count then - Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl); + else + Argv := Sequences.Constructor (0); + end if; + Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv)); + -- Execute user commands. + if Script then + Exec ("(load-file """ & ACL.Argument (1) & """)", Repl); else loop begin @@ -403,16 +434,17 @@ begin Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Mal.Nil; + Repl.all.Keep; + Garbage_Collected.Clean; end loop; Ada.Text_IO.New_Line; end if; + -- If assertions are enabled, check deallocations. - Err.Data := Mal.Nil; -- Remove references to other packages - pragma Debug (Envs.Clear_And_Check_Allocations); - pragma Debug (Atoms.Check_Allocations); - pragma Debug (Builtins.Check_Allocations); - pragma Debug (Fns.Check_Allocations); - pragma Debug (Maps.Check_Allocations); - pragma Debug (Sequences.Check_Allocations); - pragma Debug (Symbols.Check_Allocations); + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; + Symbols.Check_Allocations; end Step9_Try; diff --git a/ada.2/stepa_mal.adb b/ada.2/stepa_mal.adb index 55085370..e18839cc 100644 --- a/ada.2/stepa_mal.adb +++ b/ada.2/stepa_mal.adb @@ -1,4 +1,5 @@ with Ada.Command_Line; +with Ada.Containers.Vectors; with Ada.Environment_Variables; with Ada.Strings.Unbounded; with Ada.Text_IO.Unbounded_IO; @@ -7,10 +8,10 @@ with Core; with Envs; with Err; with Eval_Cb; +with Garbage_Collected; with Printer; with Reader; with Readline; -with Types.Atoms; with Types.Builtins; with Types.Fns; with Types.Mal; @@ -20,20 +21,19 @@ with Types.Symbols.Names; procedure StepA_Mal is - Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1"); - Dbgenv0 : constant Boolean - := Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0"); - Dbgeval : constant Boolean - := Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval"); + Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); use Types; use type Mal.T; + package ACL renames Ada.Command_Line; package ASU renames Ada.Strings.Unbounded; function Read return Mal.T_Array with Inline; function Eval (Ast0 : in Mal.T; Env0 : in Envs.Ptr) return Mal.T; + function Eval_Builtin (Args : in Mal.T_Array) return Mal.T; + -- The built-in variant needs to see the Repl variable. function Quasiquote (Ast : in Mal.T; Env : in Envs.Ptr) return Mal.T; @@ -46,7 +46,6 @@ procedure StepA_Mal is procedure Rep (Env : in Envs.Ptr) with Inline; - function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval); function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval); procedure Exec (Script : in String; @@ -62,7 +61,7 @@ procedure StepA_Mal is -- Use local variables, that can be rewritten when tail call -- optimization goes to <>. Ast : Mal.T := Ast0; - Env : Envs.Ptr := Env0.Copy_Pointer; + Env : Envs.Ptr := Env0; Macroexpanding : Boolean := False; First : Mal.T; begin @@ -71,137 +70,149 @@ procedure StepA_Mal is Ada.Text_IO.New_Line; Ada.Text_IO.Put ("EVAL: "); Print (Ast); - if Dbgenv0 then - Envs.Dump_Stack (Long => Dbgenv1); - end if; + Envs.Dump_Stack (Env.all); end if; + case Ast.Kind is when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key | Kind_Macro | Kind_Function => return Ast; when Kind_Symbol => - return Env.Get (Ast.Symbol); + return Env.all.Get (Ast.Symbol); when Kind_Map => - return Eval_Map_Elts (Ast.Map, Env); + return Eval_Map_Elts (Ast.Map.all, Env); when Kind_Vector => - return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env)); + declare + Len : constant Natural := Ast.Sequence.all.Length; + List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len); + begin + for I in 1 .. Len loop + List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env)); + end loop; + return (Kind_Vector, List); + end; when Kind_List => null; end case; -- Ast is a list. - if Ast.Sequence.Length = 0 then + if Ast.Sequence.all.Length = 0 then return Ast; end if; - First := Ast.Sequence (1); + First := Ast.Sequence.all (1); -- Special forms -- Ast is a non-empty list, First is its first element. case First.Kind is when Kind_Symbol => if First.Symbol = Symbols.Names.Def then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol, "parameter 1 must be a symbol"); - return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do - Env.Set (Ast.Sequence (2).Symbol, R); + return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do + Env.all.Set (Ast.Sequence.all (2).Symbol, R); end return; elsif First.Symbol = Symbols.Names.Defmacro then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind = Kind_Symbol, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol, "parameter 1 must be a symbol"); declare - F : constant Mal.T := Eval (Ast.Sequence (3), Env); + F : constant Mal.T := Eval (Ast.Sequence.all (3), Env); begin Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function"); - return R : constant Mal.T := F.Fn.New_Macro do - Env.Set (Ast.Sequence (2).Symbol, R); + return R : constant Mal.T := F.Fn.all.New_Macro do + Env.all.Set (Ast.Sequence.all (2).Symbol, R); end return; end; -- do is a built-in function, shortening this test cascade. elsif First.Symbol = Symbols.Names.Fn then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence, "parameter 1 must be a sequence"); - return Fns.New_Function (Params => Ast.Sequence (2).Sequence, - Ast => Ast.Sequence (3), - Env => Env.New_Closure); + return Fns.New_Function + (Params => Ast.Sequence.all (2).Sequence.all, + Ast => Ast.Sequence.all (3), + Env => Env); elsif First.Symbol = Symbols.Names.Mal_If then - Err.Check (Ast.Sequence.Length in 3 .. 4, + Err.Check (Ast.Sequence.all.Length in 3 .. 4, "expected 2 or 3 parameters"); declare - Test : constant Mal.T := Eval (Ast.Sequence (2), Env); + Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env); begin if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then - Ast := Ast.Sequence (3); + Ast := Ast.Sequence.all (3); goto Restart; - elsif Ast.Sequence.Length = 3 then + elsif Ast.Sequence.all.Length = 3 then return Mal.Nil; else - Ast := Ast.Sequence (4); + Ast := Ast.Sequence.all (4); goto Restart; end if; end; elsif First.Symbol = Symbols.Names.Let then - Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters"); - Err.Check (Ast.Sequence (2).Kind in Kind_Sequence, + Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); + Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence, "parameter 1 must be a sequence"); declare - Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence; + Bindings : constant Mal.Sequence_Ptr + := Ast.Sequence.all (2).Sequence; begin - Err.Check (Bindings.Length mod 2 = 0, + Err.Check (Bindings.all.Length mod 2 = 0, "parameter 1 must have an even length"); - Env.Replace_With_Sub; - for I in 1 .. Bindings.Length / 2 loop - Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol, + Env := Envs.New_Env (Outer => Env); + for I in 1 .. Bindings.all.Length / 2 loop + Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol, "binding keys must be symbols"); - Env.Set (Bindings (2 * I - 1).Symbol, - Eval (Bindings (2 * I), Env)); + Env.all.Set (Bindings.all (2 * I - 1).Symbol, + Eval (Bindings.all (2 * I), Env)); end loop; - Ast := Ast.Sequence (3); + Ast := Ast.Sequence.all (3); goto Restart; end; elsif First.Symbol = Symbols.Names.Macroexpand then - Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); Macroexpanding := True; - Ast := Ast.Sequence (2); + Ast := Ast.Sequence.all (2); goto Restart; elsif First.Symbol = Symbols.Names.Quasiquote then - Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); - return Quasiquote (Ast.Sequence (2), Env); + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Quasiquote (Ast.Sequence.all (2), Env); elsif First.Symbol = Symbols.Names.Quote then - Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); - return Ast.Sequence (2); + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Ast.Sequence.all (2); elsif First.Symbol = Symbols.Names.Try then - if Ast.Sequence.Length = 2 then - Ast := Ast.Sequence (2); + if Ast.Sequence.all.Length = 2 then + Ast := Ast.Sequence.all (2); goto Restart; end if; - Err.Check (Ast.Sequence.Length = 3, "expected 1 or 2 parameters"); - Err.Check (Ast.Sequence (3).Kind = Kind_List, + Err.Check (Ast.Sequence.all.Length = 3, + "expected 1 or 2 parameters"); + Err.Check (Ast.Sequence.all (3).Kind = Kind_List, "parameter 2 must be a list"); declare - A3 : constant Sequences.Ptr := Ast.Sequence (3).Sequence; + A3 : constant Mal.Sequence_Ptr := Ast.Sequence.all (3).Sequence; begin - Err.Check (A3.Length = 3, "length of parameter 2 must be 3"); - Err.Check (A3 (1) = (Kind_Symbol, Symbols.Names.Catch), + Err.Check (A3.all.Length = 3, + "length of parameter 2 must be 3"); + Err.Check (A3.all (1) = (Kind_Symbol, Symbols.Names.Catch), "parameter 3 must start with 'catch*'"); - Err.Check (A3 (2).Kind = Kind_Symbol, + Err.Check (A3.all (2).Kind = Kind_Symbol, "a symbol must follow catch*"); begin - return Eval (Ast.Sequence (2), Env); + return Eval (Ast.Sequence.all (2), Env); exception - when Err.Error => - Env.Replace_With_Sub; - Env.Set (A3 (2).Symbol, Err.Data); - Ast := A3 (3); - goto Restart; + when Err.Error => + null; end; + Env := Envs.New_Env (Outer => Env); + Env.all.Set (A3.all (2).Symbol, Err.Data); + Ast := A3.all (3); + goto Restart; end; else -- Equivalent to First := Eval (First, Env) -- except that we already know enough to spare a recursive call. - First := Env.Get (First.Symbol); + First := Env.all.Get (First.Symbol); end if; when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key | Kind_Macro | Kind_Function => @@ -220,52 +231,53 @@ procedure StepA_Mal is case First.Kind is when Kind_Builtin => declare - Args : Mal.T_Array (2 .. Ast.Sequence.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.all.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.Sequence (I), Env); + Args (I) := Eval (Ast.Sequence.all (I), Env); end loop; return First.Builtin.all (Args); end; when Kind_Builtin_With_Meta => declare - Args : Mal.T_Array (2 .. Ast.Sequence.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.all.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.Sequence (I), Env); + Args (I) := Eval (Ast.Sequence.all (I), Env); end loop; - return First.Builtin_With_Meta.Builtin.all (Args); + return First.Builtin_With_Meta.all.Builtin.all (Args); end; when Kind_Fn => declare - Args : Mal.T_Array (2 .. Ast.Sequence.Length); + Args : Mal.T_Array (2 .. Ast.Sequence.all.Length); begin for I in Args'Range loop - Args (I) := Eval (Ast.Sequence (I), Env); + Args (I) := Eval (Ast.Sequence.all (I), Env); end loop; - Env.Replace_With_Sub (Outer => First.Fn.Env, - Binds => First.Fn.Params, - Exprs => Args); - Ast := First.Fn.Ast; + Env := Envs.New_Env (Outer => First.Fn.all.Env, + Binds => First.Fn.all.Params, + Exprs => Args); + Ast := First.Fn.all.Ast; goto Restart; end; when Kind_Macro => declare Args : constant Mal.T_Array - := Ast.Sequence.Tail (Ast.Sequence.Length - 1); + := Ast.Sequence.all.Tail (Ast.Sequence.all.Length - 1); begin if Macroexpanding then -- Evaluate the macro with tail call optimization. - Env.Replace_With_Sub (Binds => First.Fn.Params, - Exprs => Args); - Ast := First.Fn.Ast; + Env := Envs.New_Env (Outer => Env, + Binds => First.Fn.all.Params, + Exprs => Args); + Ast := First.Fn.all.Ast; goto Restart; else -- Evaluate the macro normally. - Ast := Eval (First.Fn.Ast, Envs.Sub - (Outer => Env, - Binds => First.Fn.Params, - Exprs => Args)); + Ast := Eval (First.Fn.all.Ast, + Envs.New_Env (Outer => Env, + Binds => First.Fn.all.Params, + Exprs => Args)); -- Then evaluate the result with TCO. goto Restart; end if; @@ -303,46 +315,56 @@ procedure StepA_Mal is Env : in Envs.Ptr) return Mal.T is - function Quasiquote_List (List : in Sequences.Ptr) return Mal.T + function Quasiquote_List (List : in Sequences.Instance) return Mal.T with Inline; -- Handle vectors and lists not starting with unquote. - function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is - -- The final return concatenates these lists. - R : Mal.T_Array (1 .. List.Length); + function Quasiquote_List (List : in Sequences.Instance) return Mal.T is + package Vectors is new Ada.Containers.Vectors (Positive, Mal.T); + Vector : Vectors.Vector; -- buffer for concatenation + Sequence : Mal.Sequence_Ptr; + Tmp : Mal.T; begin - for I in R'Range loop - R (I) := List (I); - if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length - and then R (I).Sequence (1) = (Kind_Symbol, - Symbols.Names.Splice_Unquote) + for I in 1 .. List.Length loop + if List (I).Kind in Kind_List + and then 0 < List (I).Sequence.all.Length + and then List (I).Sequence.all (1) + = (Kind_Symbol, Symbols.Names.Splice_Unquote) then - Err.Check (R (I).Sequence.Length = 2, + Err.Check (List (I).Sequence.all.Length = 2, "splice-unquote expects 1 parameter"); - R (I) := Eval (@.Sequence (2), Env); - Err.Check (R (I).Kind = Kind_List, + Tmp := Eval (List (I).Sequence.all (2), Env); + Err.Check (Tmp.Kind = Kind_List, "splice_unquote expects a list"); + for I in 1 .. Tmp.Sequence.all.Length loop + Vector.Append (Tmp.Sequence.all (I)); + end loop; else - R (I) := Sequences.List - (Mal.T_Array'(1 => Quasiquote (@, Env))); + Vector.Append (Quasiquote (List (I), Env)); end if; end loop; - return Sequences.Concat (R); + -- Now that we know the number of elements, convert to a list. + Sequence := Sequences.Constructor (Natural (Vector.Length)); + for I in 1 .. Natural (Vector.Length) loop + Sequence.Replace_Element (I, Vector (I)); + end loop; + return (Kind_List, Sequence); end Quasiquote_List; begin -- Quasiquote case Ast.Kind is when Kind_Vector => -- When the test is updated, replace Kind_List with Kind_Vector. - return Quasiquote_List (Ast.Sequence); + return Quasiquote_List (Ast.Sequence.all); when Kind_List => - if 0 < Ast.Sequence.Length - and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote) + if 0 < Ast.Sequence.all.Length + and then Ast.Sequence.all (1) = (Kind_Symbol, + Symbols.Names.Unquote) then - Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter"); - return Eval (Ast.Sequence (2), Env); + Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); + return Eval (Ast.Sequence.all (2), Env); else - return Quasiquote_List (Ast.Sequence); + return Quasiquote_List (Ast.Sequence.all); end if; when others => return Ast; @@ -385,27 +407,37 @@ procedure StepA_Mal is & " `(let* (~condvar ~(first xs))" & " (if ~condvar ~condvar (or ~@(rest xs)))))))))" & "(def! *host-language* ""ada.2"")"; - Repl : Envs.Ptr renames Envs.Repl; + Repl : constant Envs.Ptr := Envs.New_Env; + function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is + begin + Err.Check (Args'Length = 1, "expected 1 parameter"); + return Eval_Cb.Cb.all (Args (Args'First), Repl); + end Eval_Builtin; + Script : constant Boolean := 0 < ACL.Argument_Count; + Argv : Mal.Sequence_Ptr; begin -- Show the Eval function to other packages. Eval_Cb.Cb := Eval'Unrestricted_Access; -- Add Core functions into the top environment. - Core.NS_Add_To_Repl; + Core.NS_Add_To_Repl (Repl); + Repl.all.Set (Symbols.Constructor ("eval"), + (Kind_Builtin, Eval_Builtin'Unrestricted_Access)); -- Native startup procedure. Exec (Startup, Repl); -- Define ARGV from command line arguments. - declare - use Ada.Command_Line; - Args : Mal.T_Array (2 .. Argument_Count); - begin - for I in Args'Range loop - Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I))); + if Script then + Argv := Sequences.Constructor (ACL.Argument_Count - 1); + for I in 2 .. ACL.Argument_Count loop + Argv.all.Replace_Element + (I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I)))); end loop; - Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args)); - end; - -- Script? - if 0 < Ada.Command_Line.Argument_Count then - Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl); + else + Argv := Sequences.Constructor (0); + end if; + Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv)); + -- Execute user commands. + if Script then + Exec ("(load-file """ & ACL.Argument (1) & """)", Repl); else Exec ("(println (str ""Mal ["" *host-language* ""]""))", Repl); loop @@ -418,16 +450,17 @@ begin Ada.Text_IO.Unbounded_IO.Put (Err.Trace); end; -- Other exceptions are really unexpected. + + -- Collect garbage. + Err.Data := Mal.Nil; + Repl.all.Keep; + Garbage_Collected.Clean; end loop; Ada.Text_IO.New_Line; end if; + -- If assertions are enabled, check deallocations. - Err.Data := Mal.Nil; -- Remove references to other packages - pragma Debug (Envs.Clear_And_Check_Allocations); - pragma Debug (Atoms.Check_Allocations); - pragma Debug (Builtins.Check_Allocations); - pragma Debug (Fns.Check_Allocations); - pragma Debug (Maps.Check_Allocations); - pragma Debug (Sequences.Check_Allocations); - pragma Debug (Symbols.Check_Allocations); + pragma Debug (Garbage_Collected.Clean); + Garbage_Collected.Check_Allocations; + Symbols.Check_Allocations; end StepA_Mal; diff --git a/ada.2/types-atoms.adb b/ada.2/types-atoms.adb index 54591a59..473df198 100644 --- a/ada.2/types-atoms.adb +++ b/ada.2/types-atoms.adb @@ -1,68 +1,41 @@ -with Ada.Unchecked_Deallocation; - with Err; -with Types.Mal; + +with Types.Builtins; +with Types.Fns; package body Types.Atoms is - type Rec is limited record - Refs : Natural; - Data : Mal.T; - end record; - - procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); - Allocations : Natural := 0; - - ---------------------------------------------------------------------- - - procedure Adjust (Object : in out Ptr) is - begin - Object.Ref.all.Refs := @ + 1; - end Adjust; - function Atom (Args : in Mal.T_Array) return Mal.T is + Ref : Mal.Atom_Ptr; begin Err.Check (Args'Length = 1, "expected 1 parameter"); - Allocations := Allocations + 1; - return (Kind_Atom, (Ada.Finalization.Controlled with new Rec' - (Refs => 1, - Data => Args (Args'First)))); + Ref := new Instance'(Garbage_Collected.Instance with + Data => Args (Args'First)); + Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); + return (Kind_Atom, Ref); end Atom; - procedure Check_Allocations is - begin - pragma Assert (Allocations = 0); - end Check_Allocations; - function Deref (Args : in Mal.T_Array) return Mal.T is begin Err.Check (Args'Length = 1, "expected 1 parameter"); Err.Check (Args (Args'First).Kind = Kind_Atom, "expected an atom"); - return Args (Args'First).Atom.Ref.all.Data; + return Args (Args'First).Atom.all.Data; end Deref; - function Deref (Item : in Ptr) return Mal.T - is (Item.Ref.all.Data); + function Deref (Item : in Instance) return Mal.T + is (Item.Data); - procedure Finalize (Object : in out Ptr) is + procedure Keep_References (Object : in out Instance) is begin - if Object.Ref /= null and then 0 < Object.Ref.all.Refs then - Object.Ref.all.Refs := @ - 1; - if 0 < Object.Ref.all.Refs then - Object.Ref := null; - else - Allocations := Allocations - 1; - Free (Object.Ref); - end if; - end if; - end Finalize; + Mal.Keep (Object.Data); + end Keep_References; function Reset (Args : in Mal.T_Array) return Mal.T is begin Err.Check (Args'Length = 2, "expected 2 parameters"); Err.Check (Args (Args'First).Kind = Kind_Atom, - "parameter 1 must be an atom"); - Args (Args'First).Atom.Ref.all.Data := Args (Args'Last); + "parameter 1 must be an atom"); + Args (Args'First).Atom.all.Data := Args (Args'Last); return Args (Args'Last); end Reset; @@ -73,7 +46,7 @@ package body Types.Atoms is "parameter 1 must be an atom"); declare use type Mal.T_Array; - X : Mal.T renames Args (Args'First).Atom.Ref.all.Data; + X : Mal.T renames Args (Args'First).Atom.all.Data; F : Mal.T renames Args (Args'First + 1); A : constant Mal.T_Array := X & Args (Args'First + 2 .. Args'Last); begin @@ -81,9 +54,9 @@ package body Types.Atoms is when Kind_Builtin => X := F.Builtin.all (A); when Kind_Builtin_With_Meta => - X := F.Builtin_With_Meta.Builtin.all (A); + X := F.Builtin_With_Meta.all.Builtin.all (A); when Kind_Fn => - X := F.Fn.Apply (A); + X := F.Fn.all.Apply (A); when others => Err.Raise_With ("parameter 2 must be a function"); end case; diff --git a/ada.2/types-atoms.ads b/ada.2/types-atoms.ads index c9a4f09a..6d1381b3 100644 --- a/ada.2/types-atoms.ads +++ b/ada.2/types-atoms.ads @@ -1,10 +1,9 @@ -private with Ada.Finalization; - -limited with Types.Mal; +with Garbage_Collected; +with Types.Mal; package Types.Atoms is - type Ptr is private; + type Instance (<>) is new Garbage_Collected.Instance with private; -- Built-in functions. function Atom (Args : in Mal.T_Array) return Mal.T; @@ -13,21 +12,13 @@ package Types.Atoms is function Swap (Args : in Mal.T_Array) return Mal.T; -- Helper for print. - function Deref (Item : in Ptr) return Mal.T with Inline; - - -- Debug. - procedure Check_Allocations; + function Deref (Item : in Instance) return Mal.T with Inline; private - type Rec; - type Acc is access Rec; - type Ptr is new Ada.Finalization.Controlled with record - Ref : Acc := null; - end record - with Invariant => Ptr.Ref /= null; - overriding procedure Adjust (Object : in out Ptr) with Inline; - overriding procedure Finalize (Object : in out Ptr) with Inline; - pragma Finalize_Storage_Only (Ptr); + type Instance is new Garbage_Collected.Instance with record + Data : Mal.T; + end record; + overriding procedure Keep_References (Object : in out Instance) with Inline; end Types.Atoms; diff --git a/ada.2/types-builtins.adb b/ada.2/types-builtins.adb index 9506aa89..ad20d0f7 100644 --- a/ada.2/types-builtins.adb +++ b/ada.2/types-builtins.adb @@ -1,63 +1,30 @@ -with Ada.Unchecked_Deallocation; - -with Types.Mal; - package body Types.Builtins is - type Rec is limited record - Builtin : Mal.Builtin_Ptr; - Refs : Natural; - Meta : Mal.T; - end record; + function Builtin (Item : in Instance) return Mal.Builtin_Ptr + is (Item.F_Builtin); - procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); - Allocations : Natural := 0; - - ---------------------------------------------------------------------- - - procedure Adjust (Object : in out Ptr) is + procedure Keep_References (Object : in out Instance) is begin - Object.Ref.all.Refs := @ + 1; - end Adjust; + Mal.Keep (Object.F_Meta); + end Keep_References; - function Builtin (Item : in Ptr) return Mal.Builtin_Ptr - is (Item.Ref.all.Builtin); - - procedure Check_Allocations is - begin - pragma Assert (Allocations = 0); - end Check_Allocations; - - procedure Finalize (Object : in out Ptr) is - begin - if Object.Ref /= null and then 0 < Object.Ref.all.Refs then - Object.Ref.all.Refs := @ - 1; - if 0 < Object.Ref.all.Refs then - Object.Ref := null; - else - Allocations := Allocations - 1; - Free (Object.Ref); - end if; - end if; - end Finalize; - - function Meta (Item : in Ptr) return Mal.T - is (Item.Ref.all.Meta); + function Meta (Item : in Instance) return Mal.T + is (Item.F_Meta); function With_Meta (Builtin : in Mal.Builtin_Ptr; - Metadata : in Mal.T) return Mal.T is + Metadata : in Mal.T) return Mal.T + is + Ref : constant Mal.Builtin_With_Meta_Ptr + := new Instance'(Garbage_Collected.Instance with + F_Builtin => Builtin, + F_Meta => Metadata); begin - Allocations := Allocations + 1; - return (Kind_Builtin_With_Meta, - (Ada.Finalization.Controlled with new Rec'(Builtin => Builtin, - Meta => Metadata, - Refs => 1))); + Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); + return (Kind_Builtin_With_Meta, Ref); end With_Meta; - function With_Meta (Item : in Ptr; + function With_Meta (Item : in Instance; Metadata : in Mal.T) return Mal.T - -- Do not try to reuse the memory. We can hope that this kind of - -- nonsense will be rare. - is (With_Meta (Item.Ref.all.Builtin, Metadata)); + is (With_Meta (Item.Builtin, Metadata)); end Types.Builtins; diff --git a/ada.2/types-builtins.ads b/ada.2/types-builtins.ads index a5a4af99..c180c996 100644 --- a/ada.2/types-builtins.ads +++ b/ada.2/types-builtins.ads @@ -1,6 +1,5 @@ -private with Ada.Finalization; - -limited with Types.Mal; +with Garbage_Collected; +with Types.Mal; package Types.Builtins is @@ -9,27 +8,21 @@ package Types.Builtins is -- functions. The controlled type below is only useful when one -- has the silly idea to add metadata to a built-in. - type Ptr is tagged private; + type Instance is new Garbage_Collected.Instance with private; function With_Meta (Builtin : in Mal.Builtin_Ptr; Metadata : in Mal.T) return Mal.T with Inline; - function With_Meta (Item : in Ptr; + function With_Meta (Item : in Instance; Metadata : in Mal.T) return Mal.T with Inline; - function Meta (Item : in Ptr) return Mal.T with Inline; - function Builtin (Item : in Ptr) return Mal.Builtin_Ptr with Inline; - - procedure Check_Allocations; + function Meta (Item : in Instance) return Mal.T with Inline; + function Builtin (Item : in Instance) return Mal.Builtin_Ptr with Inline; private - type Rec; - type Acc is access Rec; - type Ptr is new Ada.Finalization.Controlled with record - Ref : Acc := null; - end record - with Invariant => Ptr.Ref /= null; - overriding procedure Adjust (Object : in out Ptr) with Inline; - overriding procedure Finalize (Object : in out Ptr) with Inline; - pragma Finalize_Storage_Only (Ptr); + type Instance is new Garbage_Collected.Instance with record + F_Builtin : Mal.Builtin_Ptr; + F_Meta : Mal.T; + end record; + overriding procedure Keep_References (Object : in out Instance) with Inline; end Types.Builtins; diff --git a/ada.2/types-fns.adb b/ada.2/types-fns.adb index d9679097..cbb96bbf 100644 --- a/ada.2/types-fns.adb +++ b/ada.2/types-fns.adb @@ -1,144 +1,86 @@ -with Ada.Unchecked_Deallocation; - -with Envs; with Err; with Eval_Cb; -with Types.Mal; -with Types.Sequences; -with Types.Symbols; package body Types.Fns is - subtype AFC is Ada.Finalization.Controlled; - use type Envs.Closure_Ptr; - - type Rec (Params_Last : Natural) is limited record - Ast : Mal.T; - Refs : Natural := 1; - Env : Envs.Closure_Ptr := Envs.Null_Closure; - Meta : Mal.T := Mal.Nil; - Params : Symbols.Symbol_Array (1 .. Params_Last); - end record; - - procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); - Allocations : Natural := 0; + use type Envs.Ptr; ---------------------------------------------------------------------- - procedure Adjust (Object : in out Ptr) is - begin - Object.Ref.all.Refs := @ + 1; - end Adjust; + function Apply (Item : in Instance; + Args : in Mal.T_Array) return Mal.T + is (Eval_Cb.Cb.all (Ast => Item.F_Ast, + Env => Envs.New_Env (Outer => Item.F_Env, + Binds => Item.F_Params, + Exprs => Args))); - function Apply (Item : in Ptr; - Args : in Mal.T_Array) return Mal.T is - begin - pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure); - return Eval_Cb.Cb.all (Ast => Item.Ref.all.Ast, - Env => Envs.Sub (Outer => Item.Ref.all.Env, - Binds => Item.Ref.all.Params, - Exprs => Args)); - end Apply; + function Ast (Item : in Instance) return Mal.T + is (Item.F_Ast); - function Ast (Item : in Ptr) return Mal.T - is (Item.Ref.all.Ast); + function Env (Item : in Instance) return Envs.Ptr + is (Item.F_Env); - procedure Check_Allocations is + procedure Keep_References (Object : in out Instance) is begin - pragma Assert (Allocations = 0); - end Check_Allocations; - - function Env (Item : in Ptr) return Envs.Closure_Ptr is - begin - pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure); - return Item.Ref.all.Env; - end Env; - - procedure Finalize (Object : in out Ptr) is - begin - if Object.Ref /= null and then 0 < Object.Ref.all.Refs then - Object.Ref.all.Refs := @ - 1; - if 0 < Object.Ref.all.Refs then - Object.Ref := null; - else - Allocations := Allocations - 1; - Free (Object.Ref); - end if; + Mal.Keep (Object.F_Ast); + if Object.F_Env /= null then + Object.F_Env.all.Keep; end if; - end Finalize; + Mal.Keep (Object.F_Meta); + end Keep_References; - function Params (Item : in Ptr) return Symbols.Symbol_Array - is (Item.Ref.all.Params); + function Meta (Item : in Instance) return Mal.T + is (Item.F_Meta); - function Meta (Item : in Ptr) return Mal.T is - begin - pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure); - return Item.Ref.all.Meta; - end Meta; - - function New_Function (Params : in Sequences.Ptr; + function New_Function (Params : in Sequences.Instance; Ast : in Mal.T; - Env : in Envs.Closure_Ptr) + Env : in Envs.Ptr) return Mal.T is - Ref : Acc; + Ref : constant Mal.Fn_Ptr + := new Instance'(Garbage_Collected.Instance with + Last => Params.Length, + F_Ast => Ast, + F_Env => Env, + others => <>); begin - Allocations := Allocations + 1; - -- Avoid exceptions until Ref is controlled. - Ref := new Rec'(Params_Last => Params.Length, - Ast => Ast, - Env => Env, - others => <>); - return R : constant Mal.T := (Kind_Fn, (AFC with Ref)) do - for I in 1 .. Params.Length loop - Err.Check (Params (I).Kind = Kind_Symbol, - "formal parameters must be symbols"); - Ref.all.Params (I) := Params (I).Symbol; - end loop; - end return; + Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); + for I in Ref.all.F_Params'Range loop + Err.Check (Params (I).Kind = Kind_Symbol, + "formal parameters must be symbols"); + Ref.all.F_Params (I) := Params (I).Symbol; + end loop; + return (Kind_Fn, Ref); end New_Function; - function New_Macro (Item : in Ptr) return Mal.T is - -- Avoid raising an exception until Ref is controlled. - Ref : Acc := Item.Ref; + function New_Macro (Item : in Instance) return Mal.T is + Ref : constant Mal.Fn_Ptr + := new Instance'(Garbage_Collected.Instance with + Last => Item.Last, + F_Params => Item.F_Params, + F_Ast => Item.F_Ast, + others => <>); begin - pragma Assert (0 < Ref.all.Refs); - if Ref.all.Refs = 1 then - Ref.all.Refs := 2; - Ref.all.Env := Envs.Null_Closure; - -- Finalize the environment, it will not be used anymore. - Ref.all.Meta := Mal.Nil; - else - Allocations := Allocations + 1; - Ref := new Rec'(Params_Last => Ref.all.Params_Last, - Params => Ref.all.Params, - Ast => Ref.all.Ast, - others => <>); - end if; - return (Kind_Macro, (AFC with Ref)); + Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); + return (Kind_Macro, Ref); end New_Macro; - function With_Meta (Item : in Ptr; + function Params (Item : in Instance) return Symbols.Symbol_Array + is (Item.F_Params); + + function With_Meta (Item : in Instance; Metadata : in Mal.T) return Mal.T is - -- Avoid raising an exception until Ref is controlled. - Ref : Acc := Item.Ref; + Ref : constant Mal.Fn_Ptr + := new Instance'(Garbage_Collected.Instance with + Last => Item.Last, + F_Params => Item.F_Params, + F_Ast => Item.F_Ast, + F_Env => Item.F_Env, + F_Meta => Metadata); begin - pragma Assert (Ref.all.Env /= Envs.Null_Closure); - pragma Assert (0 < Ref.all.Refs); - if Ref.all.Refs = 1 then - Ref.all.Refs := 2; - Ref.all.Meta := Metadata; - else - Allocations := Allocations + 1; - Ref := new Rec'(Params_Last => Ref.all.Params_Last, - Params => Ref.all.Params, - Ast => Ref.all.Ast, - Env => Ref.all.Env, - Meta => Metadata, - others => <>); - end if; - return (Kind_Fn, (AFC with Ref)); + Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); + return (Kind_Fn, Ref); end With_Meta; end Types.Fns; diff --git a/ada.2/types-fns.ads b/ada.2/types-fns.ads index d3ba90fa..3127520d 100644 --- a/ada.2/types-fns.ads +++ b/ada.2/types-fns.ads @@ -1,52 +1,48 @@ -private with Ada.Finalization; - -limited with Envs; -limited with Types.Mal; -limited with Types.Sequences; -limited with Types.Symbols; +with Envs; +with Garbage_Collected; +with Types.Mal; +with Types.Sequences; +with Types.Symbols; package Types.Fns is - type Ptr is tagged private; + type Instance (<>) is new Garbage_Collected.Instance with private; -- A pointer to an user-defined function or macro. - function New_Function (Params : in Sequences.Ptr; + function New_Function (Params : in Types.Sequences.Instance; Ast : in Mal.T; - Env : in Envs.Closure_Ptr) return Mal.T + Env : in Envs.Ptr) return Mal.T with Inline; -- Raise an exception if Params contains something else than symbols. - function New_Macro (Item : in Ptr) return Mal.T with Inline; + function New_Macro (Item : in Instance) return Mal.T with Inline; - function Params (Item : in Ptr) return Symbols.Symbol_Array with Inline; - function Ast (Item : in Ptr) return Mal.T with Inline; + function Params (Item : in Instance) return Symbols.Symbol_Array + with Inline; + function Ast (Item : in Instance) return Mal.T with Inline; -- Useful to print. - function Apply (Item : in Ptr; + function Apply (Item : in Instance; Args : in Mal.T_Array) return Mal.T with Inline; - -- Fails for macros. + -- Returns null for macros. - function Env (Item : in Ptr) return Envs.Closure_Ptr with Inline; - -- Fails for macros. Required for TCO, instead of Apply. + function Env (Item : in Instance) return Envs.Ptr with Inline; + -- Returns null for macros. + -- Required for TCO, instead of Apply. - function Meta (Item : in Ptr) return Mal.T with Inline; - -- Fails for macros. - function With_Meta (Item : in Ptr; + function Meta (Item : in Instance) return Mal.T with Inline; + function With_Meta (Item : in Instance; Metadata : in Mal.T) return Mal.T with Inline; - -- Fails for macros. - - procedure Check_Allocations; private - type Rec; - type Acc is access Rec; - type Ptr is new Ada.Finalization.Controlled with record - Ref : Acc := null; - end record - with Invariant => Ptr.Ref /= null; - overriding procedure Adjust (Object : in out Ptr) with Inline; - overriding procedure Finalize (Object : in out Ptr) with Inline; - pragma Finalize_Storage_Only (Ptr); + type Instance (Last : Natural) is new Garbage_Collected.Instance + with record + F_Ast : Mal.T; + F_Env : Envs.Ptr; + F_Meta : Mal.T; + F_Params : Symbols.Symbol_Array (1 .. Last); + end record; + overriding procedure Keep_References (Object : in out Instance) with Inline; end Types.Fns; diff --git a/ada.2/types-mal.adb b/ada.2/types-mal.adb index 47bcc905..4230a6f0 100644 --- a/ada.2/types-mal.adb +++ b/ada.2/types-mal.adb @@ -1,8 +1,14 @@ +with Types.Atoms; +with Types.Builtins; +with Types.Maps; +with Types.Sequences; +with Types.Fns; + package body Types.Mal is use type Ada.Strings.Unbounded.Unbounded_String; - use type Maps.Ptr; - use type Sequences.Ptr; + use type Maps.Instance; + use type Sequences.Instance; use type Symbols.Ptr; ---------------------------------------------------------------------- @@ -22,11 +28,31 @@ package body Types.Mal is Right.Kind = Left.Kind and then Left.S = Right.S, -- Here comes the part that differs from the predefined equality. when Kind_Sequence => - Right.Kind in Kind_Sequence and then Left.Sequence = Right.Sequence, + Right.Kind in Kind_Sequence + and then Left.Sequence.all = Right.Sequence.all, when Kind_Map => - Right.Kind = Kind_Map and then Left.Map = Right.Map, + Right.Kind = Kind_Map and then Left.Map.all = Right.Map.all, -- Also, comparing functions is an interesting problem. when others => False); + procedure Keep (Object : in T) is + begin + case Object.Kind is + when Kind_Nil | Kind_Boolean | Kind_Number | Kind_Key | Kind_Builtin + | Kind_Symbol => + null; + when Kind_Atom => + Object.Atom.all.Keep; + when Kind_Sequence => + Object.Sequence.all.Keep; + when Kind_Map => + Object.Map.all.Keep; + when Kind_Builtin_With_Meta => + Object.Builtin_With_Meta.all.Keep; + when Kind_Fn | Kind_Macro => + Object.Fn.all.Keep; + end case; + end Keep; + end Types.Mal; diff --git a/ada.2/types-mal.ads b/ada.2/types-mal.ads index 33f5a2c8..425d9312 100644 --- a/ada.2/types-mal.ads +++ b/ada.2/types-mal.ads @@ -1,10 +1,10 @@ with Ada.Strings.Unbounded; -with Types.Atoms; -with Types.Builtins; -with Types.Fns; -with Types.Maps; -with Types.Sequences; +limited with Types.Atoms; +limited with Types.Builtins; +limited with Types.Fns; +limited with Types.Maps; +limited with Types.Sequences; with Types.Symbols; package Types.Mal is @@ -48,7 +48,13 @@ package Types.Mal is type T; type T_Array; + + type Atom_Ptr is access Atoms.Instance; type Builtin_Ptr is access function (Args : in T_Array) return T; + type Builtin_With_Meta_Ptr is access Builtins.Instance; + type Fn_Ptr is access Fns.Instance; + type Map_Ptr is access Maps.Instance; + type Sequence_Ptr is access Sequences.Instance; type T (Kind : Kind_Type := Kind_Nil) is record case Kind is @@ -59,21 +65,21 @@ package Types.Mal is when Kind_Number => Number : Integer; when Kind_Atom => - Atom : Atoms.Ptr; + Atom : Atom_Ptr; when Kind_Key => S : Ada.Strings.Unbounded.Unbounded_String; when Kind_Symbol => Symbol : Symbols.Ptr; when Kind_Sequence => - Sequence : Sequences.Ptr; + Sequence : Sequence_Ptr; when Kind_Map => - Map : Maps.Ptr; + Map : Map_Ptr; when Kind_Builtin => Builtin : Builtin_Ptr; when Kind_Builtin_With_Meta => - Builtin_With_Meta : Builtins.Ptr; + Builtin_With_Meta : Builtin_With_Meta_Ptr; when Kind_Fn | Kind_Macro => - Fn : Fns.Ptr; + Fn : Fn_Ptr; end case; end record; @@ -83,6 +89,8 @@ package Types.Mal is Nil : constant T := (Kind => Kind_Nil); + procedure Keep (Object : in Mal.T) with Inline; + type T_Array is array (Positive range <>) of T; end Types.Mal; diff --git a/ada.2/types-maps.adb b/ada.2/types-maps.adb index f56ae484..9f864398 100644 --- a/ada.2/types-maps.adb +++ b/ada.2/types-maps.adb @@ -1,151 +1,77 @@ -with Ada.Containers.Hashed_Maps; with Ada.Strings.Unbounded.Hash; -with Ada.Unchecked_Deallocation; with Err; with Types.Sequences; -with Types.Mal; package body Types.Maps is - subtype AFC is Ada.Finalization.Controlled; - use type Ada.Containers.Count_Type; - - function Hash (Item : in Mal.T) return Ada.Containers.Hash_Type - with Inline; - -- This function also checks the kind of the key, and raise an - -- error in case of problem. - - package HM is new Ada.Containers.Hashed_Maps (Key_Type => Mal.T, - Element_Type => Mal.T, - Hash => Hash, - Equivalent_Keys => Mal."=", - "=" => Mal."="); - use type HM.Map; - - type Rec is limited record - Refs : Natural := 1; - Data : HM.Map := HM.Empty_Map; - Meta : Mal.T := Mal.Nil; - end record; - - procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); - Allocations : Natural := 0; + function Constructor return Mal.Map_Ptr with Inline; ---------------------------------------------------------------------- - function "=" (Left, Right : in Ptr) return Boolean - is (Left.Ref.all.Data = Right.Ref.all.Data); - - procedure Adjust (Object : in out Ptr) is - begin - Object.Ref.all.Refs := @ + 1; - end Adjust; + function "=" (Left, Right : in Instance) return Boolean + is (Left.Data = Right.Data); function Assoc (Args : in Mal.T_Array) return Mal.T is - Ref : Acc; + Ref : constant Mal.Map_Ptr := Constructor; begin Err.Check (Args'Length mod 2 = 1, "expected an odd parameter count"); Err.Check (Args (Args'First).Kind = Kind_Map, "parameter 1 must be a map"); - -- Avoid exceptions until Ref is controlled. - Ref := Args (Args'First).Map.Ref; - pragma Assert (0 < Ref.all.Refs); - if Ref.all.Refs = 1 then - Ref.all.Refs := 2; - Ref.all.Meta := Mal.Nil; - else - Allocations := Allocations + 1; - Ref := new Rec'(Data => Ref.all.Data, - others => <>); - end if; - return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do - for I in 1 .. Args'Length / 2 loop - Ref.all.Data.Include (Key => Args (Args'First + 2 * I - 1), - New_Item => Args (Args'First + 2 * I)); - -- This call checks the kind of the key. - end loop; - end return; + Ref.all.Data := Args (Args'First).Map.all.Data; + for I in 1 .. Args'Length / 2 loop + Ref.all.Data.Include (Key => Args (Args'First + 2 * I - 1), + New_Item => Args (Args'First + 2 * I)); + -- This call checks the kind of the key. + end loop; + return (Kind_Map, Ref); end Assoc; - procedure Check_Allocations is - begin - pragma Assert (Allocations = 0); - end Check_Allocations; - function Contains (Args : in Mal.T_Array) return Mal.T is begin Err.Check (Args'Length = 2, "expected 2 parameters"); Err.Check (Args (Args'First).Kind = Kind_Map, "parameter 1 must be a map"); return (Kind_Boolean, - Args (Args'First).Map.Ref.all.Data.Contains (Args (Args'Last))); + Args (Args'First).Map.all.Data.Contains (Args (Args'Last))); end Contains; + function Constructor return Mal.Map_Ptr is + Ref : constant Mal.Map_Ptr := new Instance; + begin + Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); + return Ref; + end Constructor; + function Dissoc (Args : in Mal.T_Array) return Mal.T is - Ref : Acc; + Ref : constant Mal.Map_Ptr := Constructor; begin Err.Check (0 < Args'Length, "expected at least 1 parameter"); Err.Check (Args (Args'First).Kind = Kind_Map, "parameter 1 must be a map"); - -- Avoid exceptions until Ref is controlled. - Ref := Args (Args'First).Map.Ref; - pragma Assert (0 < Ref.all.Refs); - if Ref.all.Refs = 1 then - Ref.all.Refs := 2; - Ref.all.Meta := Mal.Nil; - else - Allocations := Allocations + 1; - Ref := new Rec'(Data => Ref.all.Data, - others => <>); - end if; - return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do - for I in Args'First + 1 .. Args'Last loop - Ref.all.Data.Exclude (Args (I)); - -- This call checks the kind of the key. - end loop; - end return; + Ref.all.Data := Args (Args'First).Map.all.Data; + for I in Args'First + 1 .. Args'Last loop + Ref.all.Data.Exclude (Args (I)); + -- This call checks the kind of the key. + end loop; + return (Kind_Map, Ref); end Dissoc; - procedure Finalize (Object : in out Ptr) is - begin - if Object.Ref /= null and then 0 < Object.Ref.all.Refs then - Object.Ref.all.Refs := @ - 1; - if 0 < Object.Ref.all.Refs then - Object.Ref := null; - else - Allocations := Allocations - 1; - Free (Object.Ref); - end if; - end if; - end Finalize; - - function Generic_Eval (Container : in Ptr; - Env : in Env_Type) - return Mal.T + function Generic_Eval (Container : in Instance; + Env : in Env_Type) return Mal.T is -- Copy the whole hash in order to avoid recomputing the hash -- for each key, even if it implies unneeded calls to adjust -- and finalize for Mal_Type values. - -- Avoid exceptions until Ref is controlled. - Ref : Acc := Container.Ref; + Ref : constant Mal.Map_Ptr := Constructor; begin - pragma Assert (0 < Ref.all.Refs); - if Ref.all.Refs = 1 then - Ref.all.Refs := 2; - Ref.all.Meta := Mal.Nil; - else - Allocations := Allocations + 1; - Ref := new Rec'(Data => Ref.all.Data, - others => <>); - end if; - return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do - for Position in Ref.all.Data.Iterate loop - Ref.all.Data.Replace_Element (Position, - Eval (HM.Element (Position), Env)); - -- This call may raise exceptions. - end loop; - end return; + Ref.Data := Container.Data; + for Position in Ref.all.Data.Iterate loop + Ref.all.Data.Replace_Element (Position, + Eval (HM.Element (Position), Env)); + -- This call may raise exceptions. + end loop; + return Mal.T'(Kind_Map, Ref); end Generic_Eval; function Get (Args : in Mal.T_Array) return Mal.T is @@ -158,8 +84,7 @@ package body Types.Maps is "key must be a keyword or string"); return Mal.Nil; when Kind_Map => - Position - := Args (Args'First).Map.Ref.all.Data.Find (Args (Args'Last)); + Position := Args (Args'First).Map.all.Data.Find (Args (Args'Last)); -- This call checks the kind of the key. if HM.Has_Element (Position) then return HM.Element (Position); @@ -179,86 +104,83 @@ package body Types.Maps is function Hash_Map (Args : in Mal.T_Array) return Mal.T is Binds : constant Natural := Args'Length / 2; - Ref : Acc; + Ref : Mal.Map_Ptr; begin Err.Check (Args'Length mod 2 = 0, "expected an even parameter count"); - Allocations := Allocations + 1; - -- Avoid exceptions until Ref is controlled. - Ref := new Rec; + Ref := Constructor; Ref.all.Data.Reserve_Capacity (Ada.Containers.Count_Type (Binds)); - return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do - for I in 0 .. Binds - 1 loop - Ref.all.Data.Include (Key => Args (Args'First + 2 * I), - New_Item => Args (Args'First + 2 * I + 1)); - -- This call checks the kind of the key. - end loop; - end return; + for I in 0 .. Binds - 1 loop + Ref.all.Data.Include (Key => Args (Args'First + 2 * I), + New_Item => Args (Args'First + 2 * I + 1)); + -- This call checks the kind of the key. + end loop; + return (Kind_Map, Ref); end Hash_Map; - procedure Iterate (Container : in Ptr) is + procedure Iterate (Container : in Instance) is begin - for Position in Container.Ref.all.Data.Iterate loop + for Position in Container.Data.Iterate loop Process (HM.Key (Position), HM.Element (Position)); end loop; end Iterate; + procedure Keep_References (Object : in out Instance) is + begin + for Position in Object.Data.Iterate loop + Mal.Keep (HM.Key (Position)); + Mal.Keep (HM.Element (Position)); + end loop; + Mal.Keep (Object.F_Meta); + end Keep_References; + function Keys (Args : in Mal.T_Array) return Mal.T is + A1 : Mal.Map_Ptr; + R : Mal.Sequence_Ptr; + I : Positive := 1; begin Err.Check (Args'Length = 1, "expected 1 parameter"); Err.Check (Args (Args'First).Kind = Kind_Map, "parameter 1 must be a map"); - declare - A1 : HM.Map renames Args (Args'First).Map.Ref.all.Data; - R : Mal.T_Array (1 .. Natural (A1.Length)); - I : Positive := 1; - begin - for Position in A1.Iterate loop - R (I) := HM.Key (Position); - I := I + 1; - end loop; - return Sequences.List (R); - end; + A1 := Args (Args'First).Map; + R := Sequences.Constructor (A1.all.Length); + for Position in A1.all.Data.Iterate loop + R.all.Replace_Element (I, HM.Key (Position)); + I := I + 1; + end loop; + return (Kind_List, R); end Keys; - function Meta (Container : in Ptr) return Mal.T - is (Container.Ref.all.Meta); + function Length (Container : in Instance) return Natural + is (Natural (Container.Data.Length)); + + function Meta (Container : in Instance) return Mal.T + is (Container.F_Meta); function Vals (Args : in Mal.T_Array) return Mal.T is + A1 : Mal.Map_Ptr; + R : Mal.Sequence_Ptr; + I : Positive := 1; begin Err.Check (Args'Length = 1, "expected 1 parameter"); Err.Check (Args (Args'First).Kind = Kind_Map, "parameter 1 must be a map"); - declare - A1 : HM.Map renames Args (Args'First).Map.Ref.all.Data; - R : Mal.T_Array (1 .. Natural (A1.Length)); - I : Positive := 1; - begin - for Element of A1 loop - R (I) := Element; - I := I + 1; - end loop; - return Sequences.List (R); - end; + A1 := Args (Args'First).Map; + R := Sequences.Constructor (A1.all.Length); + for Element of A1.all.Data loop + R.all.Replace_Element (I, Element); + I := I + 1; + end loop; + return (Kind_List, R); end Vals; - function With_Meta (Data : in Ptr; - Metadata : in Mal.T) - return Mal.T + function With_Meta (Data : in Instance; + Metadata : in Mal.T) return Mal.T is - -- Avoid exceptions until Ref is controlled. - Ref : Acc := Data.Ref; + Ref : constant Mal.Map_Ptr := Constructor; begin - pragma Assert (0 < Ref.all.Refs); - if Ref.all.Refs = 1 then - Ref.all.Refs := 2; - Ref.all.Meta := Metadata; - else - Allocations := Allocations + 1; - Ref := new Rec'(Data => Ref.all.Data, - Meta => Metadata, - others => <>); - end if; - return (Kind_Map, (AFC with Ref)); + Ref.all.Data := Data.Data; + Ref.all.F_Meta := Metadata; + return (Kind_Map, Ref); end With_Meta; end Types.Maps; diff --git a/ada.2/types-maps.ads b/ada.2/types-maps.ads index 58d8f450..bd472dbe 100644 --- a/ada.2/types-maps.ads +++ b/ada.2/types-maps.ads @@ -1,10 +1,11 @@ -private with Ada.Finalization; +private with Ada.Containers.Hashed_Maps; -limited with Types.Mal; +with Garbage_Collected; +with Types.Mal; package Types.Maps is - type Ptr is tagged private; + type Instance (<>) is new Garbage_Collected.Instance with private; -- Built-in functions. function Assoc (Args : in Mal.T_Array) return Mal.T; @@ -15,17 +16,19 @@ package Types.Maps is function Keys (Args : in Mal.T_Array) return Mal.T; function Vals (Args : in Mal.T_Array) return Mal.T; + function "=" (Left, Right : in Instance) return Boolean with Inline; + -- A generic is better than an access to function because of -- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89159 -- Used to evaluate each element of a map. - -- Eval is generic because units cannot depend on each other. + generic type Env_Type (<>) is limited private; with function Eval (Ast : in Mal.T; Env : in Env_Type) return Mal.T; - function Generic_Eval (Container : in Ptr; + function Generic_Eval (Container : in Instance; Env : in Env_Type) return Mal.T; @@ -33,28 +36,32 @@ package Types.Maps is generic with procedure Process (Key : in Mal.T; Element : in Mal.T); - procedure Iterate (Container : in Ptr); + procedure Iterate (Container : in Instance); - function Meta (Container : in Ptr) return Mal.T with Inline; + function Length (Container : in Instance) return Natural with Inline; - function With_Meta (Data : in Ptr; + function Meta (Container : in Instance) return Mal.T with Inline; + function With_Meta (Data : in Instance; Metadata : in Mal.T) return Mal.T; - -- Debug - procedure Check_Allocations; - private - type Rec; - type Acc is access Rec; - type Ptr is new Ada.Finalization.Controlled with record - Ref : Acc := null; - end record - with Invariant => Ptr.Ref /= null; - overriding procedure Adjust (Object : in out Ptr) with Inline; - overriding procedure Finalize (Object : in out Ptr) with Inline; - overriding function "=" (Left, Right : in Ptr) return Boolean with Inline; - pragma Finalize_Storage_Only (Ptr); + function Hash (Item : in Mal.T) return Ada.Containers.Hash_Type with Inline; + -- This function also checks the kind of the key, and raise an + -- error in case of problem. + + package HM is new Ada.Containers.Hashed_Maps (Key_Type => Mal.T, + Element_Type => Mal.T, + Hash => Hash, + Equivalent_Keys => Mal."=", + "=" => Mal."="); + use type HM.Map; + + type Instance is new Garbage_Collected.Instance with record + Data : HM.Map; + F_Meta : Mal.T; + end record; + overriding procedure Keep_References (Object : in out Instance) with Inline; end Types.Maps; diff --git a/ada.2/types-sequences.adb b/ada.2/types-sequences.adb index 751f7623..8d7098ec 100644 --- a/ada.2/types-sequences.adb +++ b/ada.2/types-sequences.adb @@ -1,68 +1,44 @@ -with Ada.Unchecked_Deallocation; - with Err; -with Types.Mal; +with Types.Builtins; +with Types.Fns; package body Types.Sequences is - subtype AFC is Ada.Finalization.Controlled; use type Mal.T_Array; - type Rec (Last : Natural) is limited record - Refs : Natural := 1; - Meta : Mal.T := Mal.Nil; - Data : Mal.T_Array (1 .. Last) := (others => Mal.Nil); - end record; - - procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); - Allocations : Natural := 0; - ---------------------------------------------------------------------- - function "=" (Left, Right : in Ptr) return Boolean is + function "=" (Left, Right : in Instance) return Boolean is -- Should become Left.Ref.all.Data = Right.Ref.all.Data when -- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89178 is fixed. use type Mal.T; - L : Rec renames Left.Ref.all; - R : Rec renames Right.Ref.all; begin - return L.Last = R.Last - and then (for all I in 1 .. L.Last => L.Data (I) = R.Data (I)); + return Left.Last = Right.Last + and then + (for all I in 1 .. Left.Last => Left.Data (I) = Right.Data (I)); end "="; function "&" (Left : in Mal.T_Array; - Right : in Ptr) return Mal.T_Array - is (Left & Right.Ref.all.Data); - - procedure Adjust (Object : in out Ptr) is - begin - Object.Ref.all.Refs := @ + 1; - end Adjust; - - procedure Check_Allocations is - begin - pragma Assert (Allocations = 0); - end Check_Allocations; + Right : in Instance) return Mal.T_Array + is (Left & Right.Data); function Concat (Args : in Mal.T_Array) return Mal.T is Sum : Natural := 0; First : Positive := 1; Last : Natural; - Ref : Acc; + Ref : Mal.Sequence_Ptr; begin for Arg of Args loop Err.Check (Arg.Kind in Kind_Sequence, "expected sequences"); - Sum := Sum + Arg.Sequence.Ref.all.Data'Length; + Sum := Sum + Arg.Sequence.all.Data'Length; end loop; - Allocations := Allocations + 1; - -- Avoid exceptions until Ref is controlled. - Ref := new Rec (Sum); + Ref := Constructor (Sum); for Arg of Args loop - Last := First - 1 + Arg.Sequence.Ref.all.Data'Length; - Ref.all.Data (First .. Last) := Arg.Sequence.Ref.all.Data; + Last := First - 1 + Arg.Sequence.all.Data'Length; + Ref.all.Data (First .. Last) := Arg.Sequence.all.Data; First := Last + 1; end loop; - return (Kind_List, (AFC with Ref)); + return (Kind_List, Ref); end Concat; function Conj (Args : in Mal.T_Array) return Mal.T is @@ -71,21 +47,20 @@ package body Types.Sequences is case Args (Args'First).Kind is when Kind_Sequence => declare - Data : Mal.T_Array renames Args (Args'First).Sequence.Ref.all.Data; + Data : Mal.T_Array renames Args (Args'First).Sequence.all.Data; Last : constant Natural := Args'Length - 1 + Data'Length; -- Avoid exceptions until Ref is controlled. - Ref : constant Acc := new Rec (Last); + Ref : constant Mal.Sequence_Ptr := Constructor (Last); begin - Allocations := Allocations + 1; if Args (Args'First).Kind = Kind_List then for I in 1 .. Args'Length - 1 loop Ref.all.Data (I) := Args (Args'Last - I + 1); end loop; Ref.all.Data (Args'Length .. Last) := Data; - return (Kind_List, (AFC with Ref)); + return (Kind_List, Ref); else Ref.all.Data := Data & Args (Args'First + 1 .. Args'Last); - return (Kind_Vector, (AFC with Ref)); + return (Kind_Vector, Ref); end if; end; when others => @@ -100,15 +75,21 @@ package body Types.Sequences is "parameter 2 must be a sequence"); declare Head : Mal.T renames Args (Args'First); - Tail : Mal.T_Array renames Args (Args'Last).Sequence.Ref.all.Data; + Tail : Mal.T_Array renames Args (Args'Last).Sequence.all.Data; + Ref : constant Mal.Sequence_Ptr := Constructor (1 + Tail'Length); begin - Allocations := Allocations + 1; - return (Kind_List, (AFC with new Rec'(Last => 1 + Tail'Length, - Data => Head & Tail, - others => <>))); + Ref.all.Data := Head & Tail; + return (Kind_List, Ref); end; end Cons; + function Constructor (Length : in Natural) return Mal.Sequence_Ptr is + Ref : constant Mal.Sequence_Ptr := new Instance (Length); + begin + Garbage_Collected.Register (Garbage_Collected.Pointer (Ref)); + return Ref; + end Constructor; + function Count (Args : in Mal.T_Array) return Mal.T is begin Err.Check (Args'Length = 1, "expected 1 parameter"); @@ -116,28 +97,15 @@ package body Types.Sequences is when Kind_Nil => return (Kind_Number, 0); when Kind_Sequence => - return (Kind_Number, Args (Args'First).Sequence.Ref.all.Data'Length); + return (Kind_Number, Args (Args'First).Sequence.all.Data'Length); when others => Err.Raise_With ("parameter must be nil or a sequence"); end case; end Count; - function Element (Container : in Ptr; + function Element (Container : in Instance; Index : in Positive) return Mal.T - is (Container.Ref.all.Data (Index)); - - procedure Finalize (Object : in out Ptr) is - begin - if Object.Ref /= null and then 0 < Object.Ref.all.Refs then - Object.Ref.all.Refs := @ - 1; - if 0 < Object.Ref.all.Refs then - Object.Ref := null; - else - Allocations := Allocations - 1; - Free (Object.Ref); - end if; - end if; - end Finalize; + is (Container.Data (Index)); function First (Args : in Mal.T_Array) return Mal.T is begin @@ -147,7 +115,7 @@ package body Types.Sequences is return Mal.Nil; when Kind_Sequence => declare - Data : Mal.T_Array renames Args (Args'First).Sequence.Ref.all.Data; + Data : Mal.T_Array renames Args (Args'First).Sequence.all.Data; begin if Data'Length = 0 then return Mal.Nil; @@ -160,48 +128,30 @@ package body Types.Sequences is end case; end First; - function Generic_Eval (Container : in Ptr; - Env : in Env_Type) - return Ptr - is - -- Avoid exceptions until Ref is controlled. - Ref : Acc := Container.Ref; - begin - pragma Assert (0 < Ref.all.Refs); - if Ref.all.Refs = 1 then - Ref.all.Refs := 2; - Ref.all.Meta := Mal.Nil; - else - Allocations := Allocations + 1; - Ref := new Rec (Ref.all.Last); - end if; - return R : constant Ptr := (AFC with Ref) do - for I in Container.Ref.all.Data'Range loop - Ref.all.Data (I) := Eval (Container.Ref.all.Data (I), Env); - -- This call may raise exceptions. - -- The target may be the source. - end loop; - end return; - end Generic_Eval; - function Is_Empty (Args : in Mal.T_Array) return Mal.T is begin Err.Check (Args'Length = 1, "expected 1 parameter"); Err.Check (Args (Args'First).Kind in Kind_Sequence, "parameter must be a sequence"); - return (Kind_Boolean, - Args (Args'First).Sequence.Ref.all.Data'Length = 0); + return (Kind_Boolean, Args (Args'First).Sequence.all.Data'Length = 0); end Is_Empty; - function Length (Source : in Ptr) return Natural - is (Source.Ref.all.Data'Length); + procedure Keep_References (Object : in out Instance) is + begin + Mal.Keep (Object.F_Meta); + for M of Object.Data loop + Mal.Keep (M); + end loop; + end Keep_References; + + function Length (Source : in Instance) return Natural + is (Source.Data'Length); function List (Args : in Mal.T_Array) return Mal.T is + Ref : constant Mal.Sequence_Ptr := Constructor (Args'Length); begin - Allocations := Allocations + 1; - return (Kind_List, (AFC with new Rec'(Data => Args, - Last => Args'Length, - others => <>))); + Ref.all.Data := Args; + return (Kind_List, Ref); end List; function Map (Args : in Mal.T_Array) return Mal.T is @@ -211,44 +161,32 @@ package body Types.Sequences is "parameter 2 must be a sequence"); declare F : Mal.T renames Args (Args'First); - Src : Mal.T_Array renames Args (Args'Last).Sequence.Ref.all.Data; - -- Avoid exceptions until Ref is controlled. - Ref : Acc := Args (Args'Last).Sequence.Ref; + Src : Mal.T_Array renames Args (Args'Last).Sequence.all.Data; + Ref : constant Mal.Sequence_Ptr := Constructor (Src'Length); begin - pragma Assert (0 < Ref.all.Refs); - if Ref.all.Refs = 1 then - Ref.all.Refs := 2; - Ref.all.Meta := Mal.Nil; - else - Allocations := Allocations + 1; - Ref := new Rec (Ref.all.Last); - end if; - return R : constant Mal.T := (Kind_List, (AFC with Ref)) do - case F.Kind is + case F.Kind is when Kind_Builtin => for I in Src'Range loop Ref.all.Data (I) := F.Builtin.all (Src (I .. I)); - -- This call may raise exceptions. - -- The target may be the same storage than the source. end loop; when Kind_Builtin_With_Meta => for I in Src'Range loop Ref.all.Data (I) - := F.Builtin_With_Meta.Builtin.all (Src (I .. I)); + := F.Builtin_With_Meta.all.Builtin.all (Src (I .. I)); end loop; when Kind_Fn => for I in Src'Range loop - Ref.all.Data (I) := F.Fn.Apply (Src (I .. I)); + Ref.all.Data (I) := F.Fn.all.Apply (Src (I .. I)); end loop; when others => Err.Raise_With ("parameter 1 must be a function"); - end case; - end return; + end case; + return (Kind_List, Ref); end; end Map; - function Meta (Item : in Ptr) return Mal.T - is (Item.Ref.all.Meta); + function Meta (Item : in Instance) return Mal.T + is (Item.F_Meta); function Nth (Args : in Mal.T_Array) return Mal.T is begin @@ -258,7 +196,7 @@ package body Types.Sequences is Err.Check (Args (Args'Last).Kind = Kind_Number, "parameter 2 must be a number"); declare - L : Mal.T_Array renames Args (Args'First).Sequence.Ref.all.Data; + L : Mal.T_Array renames Args (Args'First).Sequence.all.Data; I : constant Integer := Args (Args'Last).Number + 1; begin Err.Check (I in L'Range, "index out of bounds"); @@ -266,70 +204,62 @@ package body Types.Sequences is end; end Nth; + procedure Replace_Element (Container : in out Instance; + Index : in Positive; + New_Item : in Mal.T) + is + begin + Container.Data (Index) := New_Item; + end Replace_Element; + function Rest (Args : in Mal.T_Array) return Mal.T is begin Err.Check (Args'Length = 1, "expected 1 parameter"); declare A1 : Mal.T renames Args (Args'First); - Ref : Acc; + Ref : Mal.Sequence_Ptr; begin -- Avoid exceptions until Ref is controlled. case A1.Kind is when Kind_Nil => - Allocations := Allocations + 1; - Ref := new Rec (0); + Ref := Constructor (0); when Kind_Sequence => - Allocations := Allocations + 1; - if A1.Sequence.Ref.all.Last = 0 then - Ref := new Rec (0); + if A1.Sequence.all.Last = 0 then + Ref := Constructor (0); else - Ref := new Rec' - (Last => A1.Sequence.Ref.all.Last - 1, - Data => A1.Sequence.Ref.all.Data - (2 .. A1.Sequence.Ref.all.Data'Last), - others => <>); + Ref := Constructor (A1.Sequence.all.Last - 1); + Ref.all.Data + := A1.Sequence.all.Data (2 .. A1.Sequence.all.Data'Last); end if; when others => Err.Raise_With ("parameter must be nil or a sequence"); end case; - return (Kind_List, (AFC with Ref)); + return (Kind_List, Ref); end; end Rest; - function Tail (Source : in Ptr; + function Tail (Source : in Instance; Count : in Natural) return Mal.T_Array is - Data : Mal.T_Array renames Source.Ref.all.Data; + Data : Mal.T_Array renames Source.Data; begin return Data (Data'Last - Count + 1 .. Data'Last); end Tail; function Vector (Args : in Mal.T_Array) return Mal.T is + Ref : constant Mal.Sequence_Ptr := Constructor (Args'Length); begin - Allocations := Allocations + 1; - return (Kind_Vector, (AFC with new Rec'(Data => Args, - Last => Args'Length, - others => <>))); + Ref.all.Data := Args; + return (Kind_Vector, Ref); end Vector; - function With_Meta (Data : in Ptr; - Metadata : in Mal.T) return Ptr + function With_Meta (Data : in Instance; + Metadata : in Mal.T) return Mal.Sequence_Ptr is - -- Avoid exceptions until Ref is controlled. - Ref : Acc := Data.Ref; - + Ref : constant Mal.Sequence_Ptr := Constructor (Data.Last); begin - pragma Assert (0 < Ref.all.Refs); - if Ref.all.Refs = 1 then - Ref.all.Refs := 2; - Ref.all.Meta := Metadata; - else - Allocations := Allocations + 1; - Ref := new Rec'(Last => Ref.all.Last, - Data => Ref.all.Data, - Meta => Metadata, - others => <>); - end if; - return (AFC with Ref); + Ref.all.Data := Data.Data; + Ref.all.F_Meta := Metadata; + return Ref; end With_Meta; end Types.Sequences; diff --git a/ada.2/types-sequences.ads b/ada.2/types-sequences.ads index e195dee2..85bddb18 100644 --- a/ada.2/types-sequences.ads +++ b/ada.2/types-sequences.ads @@ -1,10 +1,9 @@ -private with Ada.Finalization; - -limited with Types.Mal; +with Garbage_Collected; +with Types.Mal; package Types.Sequences is - type Ptr is tagged private + type Instance (<>) is new Garbage_Collected.Instance with private with Constant_Indexing => Element; -- Built-in functions. @@ -20,59 +19,41 @@ package Types.Sequences is function Rest (Args : in Mal.T_Array) return Mal.T; function Vector (Args : in Mal.T_Array) return Mal.T; - function Length (Source : in Ptr) return Natural with Inline; + function "=" (Left, Right : in Instance) return Boolean with Inline; - function Element (Container : in Ptr; + function Length (Source : in Instance) return Natural with Inline; + + function Element (Container : in Instance; Index : in Positive) return Mal.T with Inline, Pre => Index <= Length (Container); function "&" (Left : in Mal.T_Array; - Right : in Ptr) return Mal.T_Array; + Right : in Instance) return Mal.T_Array with Inline; -- Used to implement Core.Apply. - -- Used to evaluate each element of a list/vector. - -- Eval is generic because units cannot depend on each other. - generic - type Env_Type (<>) is limited private; - with function Eval (Ast : in Mal.T; - Env : in Env_Type) - return Mal.T; - function Generic_Eval (Container : in Ptr; - Env : in Env_Type) - return Ptr; + function Constructor (Length : in Natural) return Mal.Sequence_Ptr + with Inline; + procedure Replace_Element (Container : in out Instance; + Index : in Positive; + New_Item : in Mal.T) + with Inline, Pre => Index <= Length (Container); -- Used in macro implementation. - function Tail (Source : in Ptr; + function Tail (Source : in Instance; Count : in Natural) return Mal.T_Array with Inline, Pre => Count <= Length (Source); - function Meta (Item : in Ptr) return Mal.T with Inline; - function With_Meta (Data : in Ptr; + function Meta (Item : in Instance) return Mal.T with Inline; + function With_Meta (Data : in Instance; Metadata : in Mal.T) - return Ptr; - - -- Debug. - procedure Check_Allocations; + return Mal.Sequence_Ptr; private - -- It is tempting to use null to represent an empty list, but the - -- performance is not improved much, and the code is more complex. - -- In addition, the empty list may want to carry metadata. - - -- Similarly, always providing a default value like a pointer to a - -- static empty list would not gain much, and probably hide some - -- bugs. - - type Rec; - type Acc is access Rec; - type Ptr is new Ada.Finalization.Controlled with record - Ref : Acc := null; - end record - with Invariant => Ptr.Ref /= null; - overriding procedure Adjust (Object : in out Ptr) with Inline; - overriding procedure Finalize (Object : in out Ptr) with Inline; - overriding function "=" (Left, Right : in Ptr) return Boolean; - pragma Finalize_Storage_Only (Ptr); + type Instance (Last : Natural) is new Garbage_Collected.Instance with record + F_Meta : Mal.T; + Data : Mal.T_Array (1 .. Last); + end record; + overriding procedure Keep_References (Object : in out Instance) with Inline; end Types.Sequences; diff --git a/ada.2/types-symbols.adb b/ada.2/types-symbols.adb index 4ca03c51..db49b2f5 100644 --- a/ada.2/types-symbols.adb +++ b/ada.2/types-symbols.adb @@ -1,42 +1,31 @@ -with Ada.Containers.Ordered_Sets; +with Ada.Containers.Hashed_Sets; with Ada.Strings.Hash; with Ada.Unchecked_Deallocation; package body Types.Symbols is - -- For the global dictionnary of symbols, an ordered set seems - -- better than a hash map. - type Rec (Last : Positive) is limited record Refs : Natural; - Hash : Ada.Containers.Hash_Type; Data : String (1 .. Last); end record; procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); Allocations : Natural := 0; - function "<" (Left, Right : in Acc) return Boolean with Inline; - function Eq (Left, Right : in Acc) return Boolean with Inline; - -- It would be unwise to name this function "=" and override the - -- predefined equality for Acc. - -- We only search by key and insert new elements, so this should - -- always return False. - package Sets is new Ada.Containers.Ordered_Sets (Element_Type => Acc, - "<" => "<", - "=" => Eq); - + function Hash (Item : in Acc) return Ada.Containers.Hash_Type with Inline; + package Sets is new Ada.Containers.Hashed_Sets (Element_Type => Acc, + Hash => Hash, + Equivalent_Elements => "=", + "=" => "="); function Key (Item : in Acc) return String with Inline; - package Keys is new Sets.Generic_Keys (Key_Type => String, - Key => Key, - "<" => Standard."<"); + package Keys is new Sets.Generic_Keys (Key_Type => String, + Key => Key, + Hash => Ada.Strings.Hash, + Equivalent_Keys => "="); Dict : Sets.Set; ---------------------------------------------------------------------- - function "<" (Left, Right : in Acc) return Boolean - is (Left.all.Data < Right.all.Data); - procedure Adjust (Object : in out Ptr) is begin Object.Ref.all.Refs := @ + 1; @@ -59,7 +48,6 @@ package body Types.Symbols is else Allocations := Allocations + 1; Ref := new Rec'(Data => Source, - Hash => Ada.Strings.Hash (Source), Last => Source'Length, Refs => 1); Dict.Insert (Ref); @@ -67,13 +55,6 @@ package body Types.Symbols is return (Ada.Finalization.Controlled with Ref); end Constructor; - function Eq (Left, Right : in Acc) return Boolean is - begin - pragma Assert (Left /= Right); - pragma Assert (Left.all.Data /= Right.all.Data); - return False; - end Eq; - procedure Finalize (Object : in out Ptr) is begin if Object.Ref /= null and then 0 < Object.Ref.all.Refs then @@ -88,8 +69,11 @@ package body Types.Symbols is end if; end Finalize; + function Hash (Item : in Acc) return Ada.Containers.Hash_Type + is (Ada.Strings.Hash (Item.all.Data)); + function Hash (Item : in Ptr) return Ada.Containers.Hash_Type - is (Item.Ref.all.Hash); + is (Ada.Strings.Hash (Item.Ref.all.Data)); function Key (Item : in Acc) return String is (Item.all.Data); diff --git a/ada.2/types-symbols.ads b/ada.2/types-symbols.ads index 7b620a81..c763a3d1 100644 --- a/ada.2/types-symbols.ads +++ b/ada.2/types-symbols.ads @@ -3,6 +3,10 @@ private with Ada.Finalization; package Types.Symbols with Preelaborate is + -- Like keys, symbols are immutable final nodes in the internal + -- data structures. For them, reference counting is probably more + -- efficient than garbage collecting. + type Ptr is tagged private; function Constructor (Source : in String) return Ptr with Inline; @@ -13,12 +17,18 @@ package Types.Symbols with Preelaborate is -- probability to end up as keys in an environment. function Hash (Item : in Ptr) return Ada.Containers.Hash_Type with Inline; - -- Equality compares the contents. + -- The implementation ensures that a given content is only + -- allocated once, so equality of pointers gives the same result + -- than comparing the strings. - type Symbol_Array is array (Positive range <>) of Symbols.Ptr; + type Symbol_Array is array (Positive range <>) of Ptr; + Empty_Array : constant Symbol_Array; + -- It is convenient to define this here because the default value + -- for Ptr is invalid. -- Debug. - procedure Check_Allocations; + procedure Check_Allocations with Inline; + -- Does nothing if assertions are disabled. private @@ -49,4 +59,9 @@ private -- Predefined equality is fine. pragma Finalize_Storage_Only (Ptr); + Empty_Array : constant Symbol_Array + := (1 .. 0 => (Ada.Finalization.Controlled with null)); + -- This will not trigger the invariant check because no element is + -- ever actually instantiated. + end Types.Symbols;