From e1b05fe8ce537f9ec069ed79229a06c2f215cc3e Mon Sep 17 00:00:00 2001 From: "Alejandro R. Mosteo" Date: Sun, 31 May 2026 16:20:48 +0200 Subject: [PATCH 1/4] wip: de-genericize --- yeison_22/alire.toml | 5 +- yeison_22/src/yeison-operators.adb | 39 + yeison_22/src/yeison-operators.ads | 17 +- yeison_22/src/yeison.adb | 934 +++++++++++++++++- yeison_22/src/yeison.ads | 418 ++++++-- yeison_22/tests/alire.toml | 16 + yeison_22/tests/common/yeison_tests.ads | 23 + .../tests/src/yeison_tests-comparisons.adb | 25 + yeison_22/tests/src/yeison_tests-crate.adb | 50 + .../tests/src/yeison_tests-image_formats.adb | 28 + yeison_22/tests/src/yeison_tests-indexing.adb | 43 + .../tests/src/yeison_tests-iterators.adb | 41 + yeison_22/tests/src/yeison_tests-literals.adb | 24 + yeison_22/tests/src/yeison_tests-maps.adb | 44 + yeison_22/tests/src/yeison_tests-scalars.adb | 32 + yeison_22/tests/src/yeison_tests-vectors.adb | 52 + yeison_22/tests/yeison_tests.gpr | 19 + 17 files changed, 1670 insertions(+), 140 deletions(-) create mode 100644 yeison_22/src/yeison-operators.adb create mode 100644 yeison_22/tests/alire.toml create mode 100644 yeison_22/tests/common/yeison_tests.ads create mode 100644 yeison_22/tests/src/yeison_tests-comparisons.adb create mode 100644 yeison_22/tests/src/yeison_tests-crate.adb create mode 100644 yeison_22/tests/src/yeison_tests-image_formats.adb create mode 100644 yeison_22/tests/src/yeison_tests-indexing.adb create mode 100644 yeison_22/tests/src/yeison_tests-iterators.adb create mode 100644 yeison_22/tests/src/yeison_tests-literals.adb create mode 100644 yeison_22/tests/src/yeison_tests-maps.adb create mode 100644 yeison_22/tests/src/yeison_tests-scalars.adb create mode 100644 yeison_22/tests/src/yeison_tests-vectors.adb create mode 100644 yeison_22/tests/yeison_tests.gpr diff --git a/yeison_22/alire.toml b/yeison_22/alire.toml index 333d6b8..dd92869 100644 --- a/yeison_22/alire.toml +++ b/yeison_22/alire.toml @@ -14,7 +14,10 @@ website = "https://github.com/mosteo/yeison" [[depends-on]] # gnat = "<13.2 | >=13.3" # Known bug with finalization at lib level -yeison_12 = "*" +yeison_12 = "*" # Only for the type-agnostic Yeison_Utils [[pins]] yeison_12 = { path='../yeison_12' } + +[test] +runner = "alire" diff --git a/yeison_22/src/yeison-operators.adb b/yeison_22/src/yeison-operators.adb new file mode 100644 index 0000000..7a97ce2 --- /dev/null +++ b/yeison_22/src/yeison-operators.adb @@ -0,0 +1,39 @@ +pragma Ada_2022; + +package body Yeison.Operators is + + --------- + -- "+" -- + --------- + + function "+" (This : Any_Array) return Any is + begin + return Result : Any := Empty_Vec do + for Elem of This loop + Result.Append (Elem); + end loop; + end return; + end "+"; + + --------- + -- "/" -- + --------- + + function "/" (L, R : Any) return Any is + begin + if L.Kind in Scalar_Kinds then + return Result : Any := Empty_Vec do + Result.Append (L); + Result.Append (R); + end return; + elsif L.Kind in Vec_Kind then + return Result : Any := L do + Result.Append (R); + end return; + else + raise Constraint_Error with + "Cannot append using ""/"" when left operator is: " & L.Kind'Image; + end if; + end "/"; + +end Yeison.Operators; diff --git a/yeison_22/src/yeison-operators.ads b/yeison_22/src/yeison-operators.ads index d64fea3..95eccf9 100644 --- a/yeison_22/src/yeison-operators.ads +++ b/yeison_22/src/yeison-operators.ads @@ -1,14 +1,17 @@ -with Yeison_Generic.Operators; +pragma Ada_2022; package Yeison.Operators with Preelaborate is - package Impl is new Yeison.Impl.Operators (Any); + -- The literal and aggregate aspects cover scalars and maps; these two + -- operators cover vectors (+[...]) and path-style building (a / b). - function "+" (This : Impl.Any_Array) return Any renames Impl.Vec; + function "+" (This : Any_Array) return Any with + Post => "+"'Result.Kind = Vec_Kind; + -- Build a vector from an array aggregate: +[1, "two", 3]. - function "/" (L, R : Any) return Any renames Impl."/"; - -- Vector concatenation a-la dir hierarchy - - package Make renames Impl.Make; + function "/" (L, R : Any) return Any with + Pre => L.Kind in Scalar_Kinds | Vec_Kind, + Post => "/"'Result.Kind = Vec_Kind; + -- Append/build a vector: a / b / c. Also handy for nested indexing paths. end Yeison.Operators; diff --git a/yeison_22/src/yeison.adb b/yeison_22/src/yeison.adb index cfad59e..1c91f3e 100644 --- a/yeison_22/src/yeison.adb +++ b/yeison_22/src/yeison.adb @@ -1,82 +1,950 @@ -with Yeison_Generic.Operators; +pragma Ada_2022; + +with Ada.Characters.Conversions; +with Ada.Characters.Wide_Wide_Latin_1; +with Ada.Strings.Wide_Wide_Fixed; +with Ada.Unchecked_Deallocation; package body Yeison is + package Fixed renames Ada.Strings.Wide_Wide_Fixed; + + use type Ada.Containers.Count_Type; + use all type Ada.Strings.Trim_End; + + subtype Any_Parent is Ada.Finalization.Controlled; + + type Any_Impl (Kind : Kinds := Bool_Kind) is record + case Kind is + when Nil_Kind => null; + + when Scalar_Kinds => + Val : Scalar_Data (Kind); + + when Map_Kind => + Map : Any_Maps.Map; + Keys : Any_Vecs.Vector; + -- Keys, in the order in which they were added + + when Vec_Kind => + Vec : Any_Vecs.Vector; + end case; + end record + with Dynamic_Predicate => + (if Any_Impl.Kind = Map_Kind then Map.Length = Keys.Length); + + function Nil_Impl return Any_Impl_Ptr + is (new Any_Impl'(Kind => Nil_Kind)); + + ---------------------------------------------------------------------------- + -- Construction (internal) ---------------------------------------------- + ---------------------------------------------------------------------------- + + -- These replace Yeison_12's public Make.* scalar constructors: clients use + -- literals (1, 3.14, "text") instead, so the builders need not be exposed. + + function New_Nil return Any + is (Any_Parent with Impl => Nil_Impl); + + function New_Bool (V : Boolean) return Any + is (Any_Parent with Impl => new Any_Impl'(Bool_Kind, (Bool_Kind, V))); + + function New_Int (V : Big_Int) return Any + is (Any_Parent with Impl => new Any_Impl'(Int_Kind, (Int_Kind, V))); + + function New_Real (V : Reals.General_Real) return Any + is (Any_Parent with Impl => new Any_Impl'(Real_Kind, (Real_Kind, V))); + + function New_Str (V : Text) return Any + is (Any_Parent with Impl => new Any_Impl'(Str_Kind, (Str_Kind, U (V)))); + + function New_Scalar (This : Scalar) return Any + is (case This.Data.Kind is + when Bool_Kind => New_Bool (This.Data.Bool), + when Int_Kind => New_Int (This.Data.Int), + when Real_Kind => New_Real (This.Data.Real), + when Str_Kind => New_Str (S (This.Data.Str))); + ------------ - -- To_Any -- + -- To_Int -- + ------------ + + function To_Int (Img : String) return Any + is (New_Int (Big_Int'Value (Img))); + + ------------- + -- To_Real -- + ------------- + + function To_Real (Img : String) return Any + is (New_Real (Reals.New_Real (Big_Real'Value (Img)))); + ------------ + -- To_Str -- + ------------ + + function To_Str (Img : Text) return Any + is (New_Str (Img)); + + --------- + -- Nil -- + --------- + + function Nil return Any is (New_Nil); + function True return Any is (New_Bool (Standard.True)); + function False return Any is (New_Bool (Standard.False)); + + ---------------------------------------------------------------------------- + -- Scalars -------------------------------------------------------------- + ---------------------------------------------------------------------------- + + function Kind (This : Scalar) return Scalar_Kinds is (This.Data.Kind); + + function As_Boolean (This : Scalar) return Boolean is (This.Data.Bool); + function As_Integer (This : Scalar) return Big_Int is (This.Data.Int); + function As_Real (This : Scalar) return Reals.General_Real + is (This.Data.Real); + function As_Text (This : Scalar) return Text is (S (This.Data.Str)); + + function Image (This : Scalar; + Format : Image_Formats := Ada_Like) return Text + is (New_Scalar (This).Image (Format)); + + ---------- + -- Kind -- + ---------- + + function Kind (This : Any) return Kinds is (This.Impl.Kind); + + ---------------- + -- Scalar "<" -- + ---------------- + + function "<" (L, R : Any_Impl) return Boolean is + use type WWUString; + use type Reals.General_Real; + + ------------------ + -- Compare_Maps -- + ------------------ + + function Compare_Maps return Boolean is + L_Cursor : Any_Maps.Cursor := L.Map.First; + R_Cursor : Any_Maps.Cursor := R.Map.First; + begin + while Any_Maps.Has_Element (L_Cursor) + and then Any_Maps.Has_Element (R_Cursor) + loop + declare + L_Key : Any renames Any_Maps.Key (L_Cursor); + R_Key : Any renames Any_Maps.Key (R_Cursor); + begin + if L_Key < R_Key then + return True; + elsif R_Key < L_Key then + return False; + end if; + + declare + L_Value : Any renames Any_Maps.Element (L_Cursor); + R_Value : Any renames Any_Maps.Element (R_Cursor); + begin + if L_Value < R_Value then + return True; + elsif R_Value < L_Value then + return False; + end if; + end; + end; + + Any_Maps.Next (L_Cursor); + Any_Maps.Next (R_Cursor); + end loop; + + -- If L is shorter than R, it is less + return Any_Maps.Has_Element (R_Cursor); + end Compare_Maps; + + ------------------ + -- Compare_Vecs -- + ------------------ + + function Compare_Vecs return Boolean is + begin + for I in L.Vec.First_Index .. L.Vec.Last_Index loop + exit when I > R.Vec.Last_Index; + declare + L_Elem : Any renames L.Vec (I); + R_Elem : Any renames R.Vec (I); + begin + if L_Elem < R_Elem then + return True; + elsif R_Elem < L_Elem then + return False; + end if; + end; + end loop; + + return L.Vec.Last_Index < R.Vec.Last_Index; + end Compare_Vecs; + + begin + if L.Kind < R.Kind then + return True; + elsif R.Kind < L.Kind then + return False; + end if; + + -- Both the same kind + + case L.Kind is + when Nil_Kind => return False; + when Bool_Kind => return L.Val.Bool < R.Val.Bool; + when Int_Kind => return L.Val.Int < R.Val.Int; + when Real_Kind => return L.Val.Real < R.Val.Real; + when Str_Kind => return L.Val.Str < R.Val.Str; + when Map_Kind => return Compare_Maps; + when Vec_Kind => return Compare_Vecs; + end case; + end "<"; + + --------- + -- "=" -- + --------- + + function "=" (L, R : Any) return Boolean + is (L.Impl.all = R.Impl.all); + + function Is_True (This : Any) return Boolean is (This.As_Bool); + function Is_False (This : Any) return Boolean is (not This.As_Bool); + + --------- + -- "<" -- + --------- + + function "<" (L, R : Any) return Boolean is + begin + if L.Kind < R.Kind then + return True; + elsif R.Kind < L.Kind then + return False; + else + return L.Impl.all < R.Impl.all; + end if; + end "<"; + + ---------------- + -- Retrieval -- + ---------------- + + function As_Scalar (This : Any'Class) return Scalar + is (Scalar'(Data => This.Impl.Val)); + + function As_Bool (This : Any) return Boolean is (This.Impl.Val.Bool); + + function As_Int (This : Any) return Big_Int is (This.Impl.Val.Int); + + function As_Real (This : Any) return Reals.General_Real + is (This.Impl.Val.Real); + + function As_Real_Float (This : Any) return Big_Real is + use type Reals.Classes; + General : Reals.General_Real renames This.Impl.Val.Real; + begin + if General.Class /= Reals.Finite then + raise Constraint_Error + with "non-finite real value has no Big_Real representation"; + end if; + return General.Value; + end As_Real_Float; + + function As_Text (This : Any) return Text is (S (This.Impl.Val.Str)); + + function As_UTF_8 (This : Any) return String + is (Yeison_Utils.Encode (This.As_Text)); + + function As_Latin_1 (This : Any) return String + is (Ada.Characters.Conversions.To_String (This.As_Text)); + + --------------- + -- Empty_Map -- + --------------- + + function Empty_Map return Any + is (Any_Parent with Impl => new Any_Impl'(Kind => Map_Kind, others => <>)); + + --------------- + -- Empty_Vec -- + --------------- + + function Empty_Vec return Any + is (Any_Parent with Impl => new Any_Impl'(Kind => Vec_Kind, others => <>)); + + ----------------- + -- First_Index -- + ----------------- + + function First_Index (This : Any) return Universal_Integer + is (Universal_Integer (This.Impl.Vec.First_Index)); + + ---------------- + -- Last_Index -- + ---------------- + + function Last_Index (This : Any) return Universal_Integer + is (Universal_Integer (This.Impl.Vec.Last_Index)); + + ---------------- + -- JSON_Quote -- + ---------------- + + function JSON_Quote (Str : Text) return Text + is ('"' & Yeison_Utils.JSON_Escape (Str) & '"'); + + ----------- + -- Image -- + ----------- + + function Image (This : Any'Class; + Format : Image_Formats := Ada_Like; + Options : Image_Options := (others => <>)) + return Text + is + use Ada.Strings.Wide_Wide_Unbounded; + + ------------------ + -- Scalar_Image -- + ------------------ + + function Scalar_Image (This : Any'Class) return Text + is (case This.Kind is + when Bool_Kind => + (if This.Impl.Val.Bool then "true" else "false"), + when Int_Kind => + Fixed.Trim (Big_Int'Wide_Wide_Image (This.Impl.Val.Int), + Side => Both), + when Real_Kind => + Fixed.Trim (Reals.Image (This.Impl.Val.Real), Side => Both), + when Str_Kind => + (case Format is + when Ada_Like => + To_Wide_Wide_String (This.Impl.Val.Str), + when JSON => + JSON_Quote (To_Wide_Wide_String (This.Impl.Val.Str))), + when Nonscalar_Kinds => + raise Program_Error with "not a scalar: " & This.Kind'Image + ); + + Result : WWUString; + + function Empty_Map_Image return Text + is (case Format is when Ada_Like => "(=>)", when JSON => "{}"); + + function Map_Open return Text + is (case Format is when Ada_Like => "(", when JSON => "{"); + + function Map_Close return Text + is (case Format is when Ada_Like => ")", when JSON => "}"); + + function Map_Arrow return Text + is (case Format is when Ada_Like => " => ", when JSON => ": "); + + function Empty_Vec_Image return Text + is (case Format is when Ada_Like => "()", when JSON => "[]"); + + function Vec_Open return Text + is (case Format is when Ada_Like => "(", when JSON => "["); + + function Vec_Close return Text + is (case Format is when Ada_Like => ")", when JSON => "]"); + + -------------- + -- Traverse -- + -------------- + + procedure Traverse (This : Any'Class; + Prefix : Text; + Contd : Boolean := False) + is + NL : constant Text := "" & Ada.Characters.Wide_Wide_Latin_1.LF; + Tab : constant Text := + (case Format is when Ada_Like => " ", when JSON => " "); + begin + case This.Kind is + when Nil_Kind => + Append (Result, (if Contd then Text'("") else Prefix) & "null"); + + when Scalar_Kinds => + Append (Result, + (if Contd then Text'("") else Prefix) + & Scalar_Image (This)); + + when Map_Kind => + declare + C_Map : Any_Maps.Cursor := This.Impl.Map.First; + C_Vec : Any_Vecs.Cursor := This.Impl.Keys.First; + use Any_Maps; + use Any_Vecs; + Abbr : constant Boolean := + Options.Compact and then This.Impl.Map.Length in 1; + begin + if This.Impl.Map.Is_Empty then + Append (Result, + (if Contd then "" else Prefix) & Empty_Map_Image); + return; + end if; + + Append (Result, + (if Contd then "" else Prefix) + & Map_Open + & (if Abbr then " " else NL)); + + while (if Options.Ordered_Keys + then Any_Maps.Has_Element (C_Map) + else Any_Vecs.Has_Element (C_Vec)) + loop + Append (Result, + (if Abbr then " " else Prefix & Tab) + & (if Options.Ordered_Keys + then Any_Maps.Key (C_Map) + .Image (Format, Options) + else Any_Vecs.Element (C_Vec) + .Image (Format, Options)) + & Map_Arrow); + + Traverse ((if Options.Ordered_Keys + then This.Impl.Map.Constant_Reference (C_Map) + else This.Impl.Map.Constant_Reference + (This.Impl.Map.Find + (Any_Vecs.Element (C_Vec)))), + Prefix & Tab, + Contd => True); - function To_Any (This : Impl.Any) return Any - is (This with null record); + if (if Options.Ordered_Keys + then Any_Maps.Has_Element (Next (C_Map)) + else Any_Vecs.Has_Element (Next (C_Vec))) + then + Append (Result, ","); + end if; - package Operators is new Impl.Operators (Any); + if not Abbr then + Append (Result, NL); + end if; - package References is new Impl.References (Any); + if Options.Ordered_Keys then + Next (C_Map); + else + Next (C_Vec); + end if; + end loop; - package Make renames Operators.Make; + Append (Result, + (if Abbr then " " else Prefix) & Map_Close); + end; - function Nil return Any renames Make.Nil; - function False return Any renames Make.False; - function True return Any renames Make.True; + when Vec_Kind => + declare + Abbr : constant Boolean := + Options.Compact and then This.Impl.Vec.Length in 1; + I : Natural := 0; + begin + if This.Impl.Vec.Is_Empty then + Append (Result, + (if Contd then "" else Prefix) + & Empty_Vec_Image); + return; + end if; + + Append (Result, + (if Contd then "" else Prefix) + & Vec_Open + & (if Abbr then " " else NL)); + + for E of This.Impl.Vec loop + Traverse (E, Prefix & Tab, Contd => Abbr); + I := I + 1; + Append (Result, + (if I = Natural (This.Impl.Vec.Length) + then "" + else ",") + & (if Abbr then " " else NL)); + end loop; + Append (Result, + (if Abbr then "" else Prefix) + & Vec_Close); + end; + end case; + end Traverse; + + begin + Traverse (This, ""); + + return To_Wide_Wide_String (Result); + end Image; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (This : Any) return Boolean + is (case This.Kind is + when Nil_Kind => True, + when Map_Kind => This.Impl.Map.Is_Empty, + when Vec_Kind => This.Impl.Vec.Is_Empty, + when others => + raise Constraint_Error + with "not a collection: " & This.Kind'Image); + + --------------- + -- Has_Value -- + --------------- + + function Has_Value (This : Any) return Boolean + is (This.Kind /= Nil_Kind); ------------ - -- As_Ref -- + -- Length -- + ------------ + + function Length (This : Any) return Universal_Integer + is (case This.Kind is + when Map_Kind => Universal_Integer (This.Impl.Map.Length), + when Vec_Kind => Universal_Integer (This.Impl.Vec.Length), + when others => + raise Constraint_Error + with "not a collection: " & This.Kind'Image); + ------------ + -- Adjust -- + ------------ + + overriding procedure Adjust (This : in out Any) is + begin + This.Impl := new Any_Impl'(This.Impl.all); + end Adjust; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (This : in out Any) is + procedure Free is + new Ada.Unchecked_Deallocation (Any_Impl, Any_Impl_Ptr); + begin + Free (This.Impl); + end Finalize; + + ------------ + -- Append -- + ------------ + + procedure Append (This : in out Any; Elem : Any) is + begin + This.Impl.Vec.Append (Elem); + end Append; + + function Append (This : Any; Elem : Any) return Any is + begin + return Result : Any := This do + Result.Append (Elem); + end return; + end Append; - function As_Ref (This : aliased Any) return Ref - is (Element => This'Unrestricted_Access); + ----------------- + -- Insert_Impl -- + ----------------- + + procedure Insert_Impl (Impl : in out Any_Impl; + Key : Any; + Value : Any; + Replace : Boolean := False) + is + begin + if Replace and then Impl.Map.Contains (Key) then + Impl.Map.Replace (Key, Value); + -- The key already exists, no need to update the Keys vector + else + Impl.Map.Insert (Key, Value); + Impl.Keys.Append (Key); + end if; + end Insert_Impl; ------------ -- Insert -- ------------ + --------- + -- Set -- + --------- + + -- In-place, any-keyed insertion. Internal (the public any-keyed insertion + -- is the functional Insert, or M (Key) := Value through indexing). + + procedure Set (This : in out Any; + Key : Any; + Value : Any; + Replace : Boolean := False) + is + begin + Insert_Impl (This.Impl.all, Key, Value, Replace); + end Set; + procedure Insert (This : in out Any; Key : Text; Value : Any) is begin - This.Insert (To_Str (Key), Value, Replace => False); + Set (This, New_Str (Key), Value); end Insert; - ------------ - -- To_Int -- - ------------ + function Insert (This : Any; + Key : Any; + Value : Any; + Replace : Boolean := False) + return Any + is + begin + return Result : Any := This do + Set (Result, Key, Value, Replace); + end return; + end Insert; - function To_Int (Img : String) return Any - is (Operators.Make.Int (Big_Integers.From_String (Img))); + ---------- + -- Keys -- + ---------- + + function Keys (This : Any; Ordered : Boolean := False) return Any is + begin + return Result : Any := Empty_Vec do + if Ordered then + for I in This.Impl.Map.Iterate loop + Result.Append (Any_Maps.Key (I)); + end loop; + else + for Key of This.Impl.Keys loop + Result.Append (Key); + end loop; + end if; + end return; + end Keys; ------------- - -- To_Real -- + -- Has_Key -- ------------- - function To_Real (Img : String) return Any - is (Operators.Make.Real (Big_Reals.From_String (Img))); + function Has_Key (This : Any; Key : Any) return Boolean + is (This.Impl.Map.Contains (Key)); - ------------ - -- To_Str -- - ------------ + ---------- + -- Head -- + ---------- + + function Head (This : Any) return Any + is (This.Impl.Vec.First_Element); + + ---------- + -- Tail -- + ---------- + + function Tail (This : Any) return Any is + begin + if This.Is_Empty then + raise Constraint_Error with "Tail of empty vector"; + end if; + return Result : Any := Empty_Vec do + for I in This.Impl.Vec.First_Index + 1 .. This.Impl.Vec.Last_Index + loop + Result.Append (This.Impl.Vec (I)); + end loop; + end return; + end Tail; + + ------------- + -- Resolve -- + ------------- + + -- Single position resolver shared by Reference (read/write) and + -- Constant_Reference (read-only). It returns an access to the designated + -- element. When Create, missing positions are materialized: a nil target + -- is auto-vivified into the proper container, a vector is grown by exactly + -- one past its end, and a missing map key is inserted as nil. When not + -- Create, any invalid index/key raises Constraint_Error and This is left + -- untouched. + + function Resolve (This : Any; + Pos : Any; + Create : Boolean) return not null access Any + is + Target : constant not null access Any := This'Unrestricted_Access; + + ---------------------- + -- Constraint_Error -- + ---------------------- + + procedure Constraint_Error (Msg : String) is + begin + raise Standard.Constraint_Error + with "cannot index " & Msg & " when index is " + & Yeison_Utils.Encode (Pos.Image); + end Constraint_Error; + + begin + case Pos.Kind is + when Nil_Kind => + Constraint_Error ("with null index"); + + when Map_Kind => + Constraint_Error ("with a map"); + + when Vec_Kind => + -- Nested indexing: consume one position at a time + if Pos.Is_Empty then + raise Standard.Constraint_Error + with "cannot index with empty vector"; + elsif Pos.Length = 1 then + return Resolve (Target.all, Head (Pos), Create); + else + return Resolve (Resolve (Target.all, Head (Pos), Create).all, + Tail (Pos), Create); + end if; + + when Scalar_Kinds => + -- Auto-vivify a nil target (only when creating) + if Target.Is_Nil and then Create then + if Pos.Kind = Int_Kind then + Target.all := Empty_Vec; + else + Target.all := Empty_Map; + end if; + end if; - function To_Str (Img : Text) return Any renames Operators.Make.Str; + case Target.Kind is + when Map_Kind => + if not Target.Impl.Map.Contains (Pos) then + if Create then + Insert_Impl (Target.Impl.all, Pos, New_Nil); + else + Constraint_Error ("a map without the key"); + end if; + end if; + + return Target.Impl.Map.Reference (Pos).Element.all + 'Unrestricted_Access; + + when Vec_Kind => + if Pos.Kind /= Int_Kind then + Constraint_Error ("a vector with a non-integer index"); + end if; + + declare + Index : constant Universal_Integer := Pos.As_Int; + Len : constant Universal_Integer := + Universal_Integer (Target.Impl.Vec.Length); + begin + if Index <= 0 then + Constraint_Error + ("a vector with non-positive index " & Index'Image); + elsif Create then + if Index > Len + 1 then + Constraint_Error + ("a vector beyond 'length + 1 when 'length =" + & Len'Image); + elsif Index = Len + 1 then + Target.Impl.Vec.Append (New_Nil); + end if; + elsif Index > Len then + Constraint_Error ("a vector out of range"); + end if; + + return Target.Impl.Vec.Reference (Index).Element.all + 'Unrestricted_Access; + end; + + when Nil_Kind | Scalar_Kinds => + Constraint_Error ("a non-composite value"); + end case; + end case; + + -- Unreachable: every branch above either returns or raises. + raise Program_Error; + end Resolve; --------------- - -- Const_Ref -- + -- Reference -- --------------- - function Const_Ref (This : aliased Any; Pos : Any) return Const - is (Element => References.Reference (This, Pos)); + function Reference (This : in out Any; Pos : Any) return Ref + is (Ref'(Element => Resolve (This, Pos, Create => True))); --------- -- Get -- --------- - function Get (This, Pos : Any) return Any - renames References.Get; + function Get (This : Any; Pos : Any) return Any + is (Resolve (This, Pos, Create => False).all); + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference (This : Any; Pos : Any) return Const + is (Const'(Element => Resolve (This, Pos, Create => False))); + + ---------------------------------------------------------------------------- + -- Iteration ------------------------------------------------------------ + ---------------------------------------------------------------------------- + + ------------------ + -- First_Cursor -- + ------------------ + + function First_Cursor (This : Any) return Cursor is + begin + case This.Kind is + when Map_Kind => + if This.Impl.Map.Is_Empty then + return (Kind => Invalid); + else + return (Kind => Map_Cursor, Map_Pos => This.Impl.Map.First); + end if; + when Vec_Kind => + if This.Impl.Vec.Is_Empty then + return (Kind => Invalid); + else + return (Kind => Vec_Cursor, Vec_Pos => This.Impl.Vec.First); + end if; + when others => + return (Kind => Invalid); + end case; + end First_Cursor; + + ----------------- + -- Next_Cursor -- + ----------------- + + function Next_Cursor (Pos : Cursor) return Cursor is + begin + case Pos.Kind is + when Map_Cursor => + declare + Next_Pos : Any_Maps.Cursor := Pos.Map_Pos; + begin + Any_Maps.Next (Next_Pos); + if Any_Maps.Has_Element (Next_Pos) then + return (Kind => Map_Cursor, Map_Pos => Next_Pos); + else + return (Kind => Invalid); + end if; + end; + when Vec_Cursor => + declare + Next_Pos : Any_Vecs.Cursor := Pos.Vec_Pos; + begin + Any_Vecs.Next (Next_Pos); + if Any_Vecs.Has_Element (Next_Pos) then + return (Kind => Vec_Cursor, Vec_Pos => Next_Pos); + else + return (Kind => Invalid); + end if; + end; + when Invalid => + return Pos; + end case; + end Next_Cursor; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Pos : Cursor) return Boolean + is (Pos.Kind /= Invalid); + + ----------- + -- First -- + ----------- + + function First (This : Any) return Cursor + is (First_Cursor (This)); + + overriding function First (Object : Iterator) return Cursor + is (First_Cursor (Object.Container.all)); + + ------------- + -- Element -- + ------------- + + function Element (This : Any; Pos : Cursor) return Any + is (Constant_Reference (This, Pos).Element.all); + + --------- + -- Key -- + --------- + + function Key (This : Any; Pos : Cursor) return Any is + pragma Unreferenced (This); + begin + case Pos.Kind is + when Map_Cursor => + return Any_Maps.Key (Pos.Map_Pos); + when Vec_Cursor => + raise Constraint_Error with "Key called on a vector cursor"; + when Invalid => + raise Constraint_Error with "Key called on an invalid cursor"; + end case; + end Key; + + ---------- + -- Next -- + ---------- + + overriding function Next (Object : Iterator; + Position : Cursor) return Cursor + is (Next_Cursor (Position)); + + ------------- + -- Iterate -- + ------------- + + function Iterate (This : Any) return Iteration.Forward_Iterator'Class + is (Iterator'(Container => This'Unrestricted_Access)); + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference (This : Any; Pos : Cursor) return Const is + begin + case Pos.Kind is + when Map_Cursor => + -- For maps, we return just the value part, discarding the key + return Const'(Element => + This.Impl.Map.Constant_Reference (Pos.Map_Pos).Element); + when Vec_Cursor => + return Const'(Element => + This.Impl.Vec.Constant_Reference (Pos.Vec_Pos).Element); + when Invalid => + raise Constraint_Error with "invalid cursor"; + end case; + end Constant_Reference; --------------- -- Reference -- --------------- - function Reference (This : aliased Any; Pos : Any) return Ref - is (Element => References.Reference (This, Pos)); + function Reference (This : in out Any; Pos : Cursor) return Ref is + begin + case Pos.Kind is + when Map_Cursor => + return Ref'(Element => + This.Impl.Map.Reference (Pos.Map_Pos).Element.all + 'Unrestricted_Access); + when Vec_Cursor => + return Ref'(Element => + This.Impl.Vec.Reference (Pos.Vec_Pos).Element.all + 'Unrestricted_Access); + when Invalid => + raise Constraint_Error with "invalid cursor"; + end case; + end Reference; end Yeison; diff --git a/yeison_22/src/yeison.ads b/yeison_22/src/yeison.ads index bfc9dfb..d063ac5 100644 --- a/yeison_22/src/yeison.ads +++ b/yeison_22/src/yeison.ads @@ -1,112 +1,268 @@ pragma Ada_2022; -private with Ada.Characters.Conversions; -with Ada.Numerics.Big_Numbers.Big_Integers; -with Ada.Numerics.Big_Numbers.Big_Reals; +with Ada.Finalization; +with Ada.Iterator_Interfaces; -with Yeison_Generic; +private with Ada.Containers.Ordered_Maps; +private with Ada.Containers.Vectors; +private with Ada.Strings.Wide_Wide_Unbounded; + +with Yeison_Utils; package Yeison with Preelaborate is - --------------------- - -- Preliminaries -- - --------------------- + -- Self-contained Ada 2022 implementation. It deliberately does not reuse + -- Yeison_12's storage: that type stores Yeison_12.Any in its containers, so + -- a wrapper could not hand back zero-copy references of the user-facing + -- type for "M (Key) := Value". Here the containers store this package's own + -- Any, so indexing, references and "for E of X" are native. The only thing + -- reused from the Yeison_12 crate is the type-agnostic Yeison_Utils. + -- + -- Compared with Yeison_12 the user-facing surface is trimmed: the literal + -- and aggregate aspects make the "+scalar" constructors and the extra + -- Text/Int convenience overloads unnecessary (and, with the literal + -- aspects, ambiguous), so they are gone. Construction is via literals, + -- ["k" => v] map aggregates and +[...] vectors. - -- These enable the instantiation below of Any; can be skipped. They - -- cannot be private as we want to visibly inherit lots of operations - -- from Yeison_Generic. + subtype Big_Int is Long_Long_Integer; + subtype Big_Real is Long_Long_Float; - use Ada.Numerics.Big_Numbers; + subtype Universal_Integer is Long_Long_Integer; + -- The widest integer we represent; doubles as vector index base. - package Bigint_Conversions is - new Big_Integers.Signed_Conversions (Long_Long_Integer); + function Nicer_Image (R : Big_Real) return Wide_Wide_String; + -- Avoid scientific notation when easy to do so - function Image (I : Big_Integers.Big_Integer) return Wide_Wide_String; - function Image (R : Big_Reals.Big_Real) return Wide_Wide_String; + package Reals is new Yeison_Utils.General_Reals (Big_Real, "<", Nicer_Image); - package Impl is - new Yeison_Generic (Big_Integers.Big_Integer, - Bigint_Conversions.From_Big_Integer, - Image, + subtype Text is Wide_Wide_String; + subtype UTF_8_String is String; - Big_Reals.Big_Real, - Image, + ----------- + -- Kinds -- + ----------- - Big_Integers."<", - Big_Reals."<"); + type Kinds is (Nil_Kind, + -- Uninitialized or explicitly null value - use all type Impl.Kinds; + Bool_Kind, + Int_Kind, + Real_Kind, + Str_Kind, + -- Scalar kinds; a single value - subtype Scalar_Kinds is Impl.Scalar_Kinds; + Map_Kind, + Vec_Kind + -- Composite kinds; a collection of elements + ); - subtype Composite_Kinds is Impl.Composite_Kinds; + subtype Scalar_Kinds + is Kinds range Kinds'Succ (Nil_Kind) .. Kinds'Pred (Map_Kind); - subtype Text is Impl.Text; + subtype Composite_Kinds is Kinds range Map_Kind .. Kinds'Last; - ----------- - -- Any -- - ----------- + subtype Nonscalar_Kinds is Kinds with + Static_Predicate => Nonscalar_Kinds in Nil_Kind | Composite_Kinds; - type Any is new Impl.Any with private with - Aggregate => (Empty => Empty_Map, - Add_Named => Insert), + --------- + -- Any -- + --------- + + type Any is new Ada.Finalization.Controlled with private with + Aggregate => (Empty => Empty_Map, + Add_Named => Insert), Integer_Literal => To_Int, Real_Literal => To_Real, String_Literal => To_Str, - Constant_Indexing => Const_Ref, - Variable_Indexing => Reference; - -- We need a new derived type because user literal aspects cannot be - -- applied to subtypes (drats). - - -- Check Yeison_Generic spec for the full features of the type that are - -- inherited here. - - -- These are problematic, as declaring using them doesn't really assign - -- the expected kind to the variable, and for maps and vectors it results - -- in spurious invalid initialization. Use at your own risk, they'll be - -- probably deprecated at some point... + Variable_Indexing => Reference, + Constant_Indexing => Constant_Reference, + Default_Iterator => Iterate, + Iterator_Element => Any; + -- The literal aspects let plain 1, 3.14 and "text" denote an Any; the + -- Aggregate aspect enables ["key" => value] map literals; +[...] (see + -- Yeison.Operators) builds vectors. Iteration uses Ada.Iterator_Interfaces + -- rather than the GNAT-specific Iterable aspect (see Yeison_12 for why). + + function "=" (L, R : Any) return Boolean; + -- Note: X = "text" / X = 1 work via the literal aspects on the right-hand + -- side, so the Text/Int convenience overloads of Yeison_12 are not needed. + + function "<" (L, R : Any) return Boolean; + function Precedes (L, R : Any) return Boolean renames "<"; subtype Bool is Any with Dynamic_Predicate => Bool.Kind = Bool_Kind; - subtype Int is Any with Dynamic_Predicate => Int.Kind = Int_Kind; - subtype Map is Any with - Dynamic_Predicate => Map.Kind in Nil_Kind | Map_Kind; + subtype Int is Any with Dynamic_Predicate => Int.Kind = Int_Kind; subtype Real is Any with Dynamic_Predicate => Real.Kind = Real_Kind; - subtype Str is Any with Dynamic_Predicate => Str.Kind = Str_Kind; - subtype Vec is Any with + subtype Str is Any with Dynamic_Predicate => Str.Kind = Str_Kind; + subtype Map is Any with + Dynamic_Predicate => Map.Kind in Nil_Kind | Map_Kind; + subtype Vec is Any with Dynamic_Predicate => Vec.Kind in Nil_Kind | Vec_Kind; - function Nil return Any; + type Any_Array is array (Positive range <>) of Any; + + -------------- + -- Common -- + -------------- + + type Image_Formats is (Ada_Like, JSON); + + type Image_Options is record + Compact : Boolean := False; + Ordered_Keys : Boolean := False; + end record; + + function Image (This : Any'Class; + Format : Image_Formats := Ada_Like; + Options : Image_Options := (others => <>)) + return Text; + + function Has_Value (This : Any) return Boolean with + Post => Has_Value'Result = (This.Kind /= Nil_Kind); + + function Kind (This : Any) return Kinds; + + function Is_Nil (This : Any) return Boolean is (This.Kind = Nil_Kind); + function Is_True (This : Any) return Boolean with Pre => This.Kind = Bool_Kind; + function Is_False (This : Any) return Boolean with Pre => This.Kind = Bool_Kind; + + function Nil return Any; + function True return Any; function False return Any; - function True return Any; --------------- -- Scalars -- --------------- + -- Literal aspect targets. They are public because the aspects reference + -- them; clients use literals (1, 3.14, "text") rather than calling these. + function To_Int (Img : String) return Any; function To_Real (Img : String) return Any; - function To_Str (Img : Text) return Any; + function To_Str (Img : Text) return Any; - ----------- - -- Map -- - ----------- + -- Separate scalar type, to ease retrieval - -- Minimal facilities to enable aspects. Full operations in Yeison_Generic + type Scalar (<>) is tagged private; + + function Kind (This : Scalar) return Scalar_Kinds; + + function As_Boolean (This : Scalar) return Boolean; + function As_Integer (This : Scalar) return Big_Int; + function As_Real (This : Scalar) return Reals.General_Real; + function As_Text (This : Scalar) return Text; + + function Image (This : Scalar; + Format : Image_Formats := Ada_Like) return Text; + + -- Retrieval + + function As_Scalar (This : Any'Class) return Scalar + with Pre => This.Kind in Scalar_Kinds; + + function As_Bool (This : Any) return Boolean + with Pre => This.Kind = Bool_Kind; + + function As_Int (This : Any) return Big_Int + with Pre => This.Kind = Int_Kind; + + function As_Real (This : Any) return Reals.General_Real + with Pre => This.Kind = Real_Kind; + + function As_Real_Float (This : Any) return Big_Real + with Pre => This.Kind = Real_Kind; + -- Raises Constraint_Error for non-finite values (Inf/NaN). + + function As_Text (This : Any) return Text + with Pre => This.Kind = Str_Kind; + + function As_UTF_8 (This : Any) return String + with Pre => This.Kind = Str_Kind; + + function As_Latin_1 (This : Any) return String + with Pre => This.Kind = Str_Kind; + + -- Overloaded renamings + function Get (This : Any'Class) return Scalar renames As_Scalar; + function Get (This : Any) return Boolean renames As_Bool; + function Get (This : Any) return Big_Int renames As_Int; + function Get (This : Any) return Reals.General_Real renames As_Real; + function Get (This : Any) return Text renames As_Text; + + ------------------- + -- Collections -- + ------------------- + + function Is_Empty (This : Any) return Boolean with + Pre => This.Is_Nil or else This.Kind in Composite_Kinds; + + function Length (This : Any) return Universal_Integer with + Pre => This.Kind in Composite_Kinds; + + ------------ + -- Maps -- + ------------ + + function Empty_Map return Any + with Post => Empty_Map'Result.Kind = Map_Kind; procedure Insert (This : in out Any; Key : Text; Value : Any); + -- Add_Named operation for ["key" => value] aggregates, and in-place + -- string-keyed insertion. (A Text key, rather than Any, lets both string + -- literals and Text variables be used as keys, and avoids a literal + -- ambiguity with the functional Any-keyed Insert below. For in-place + -- insertion with a non-string or replacing key use indexing: M (Key) := V.) + + function Insert (This : Any; + Key : Any; + Value : Any; + Replace : Boolean := False) + return Any; + -- Returns a *copy* with the new inserted value; keys may be any scalar. + + function Keys (This : Any; Ordered : Boolean := False) return Any with + Pre => This.Kind = Map_Kind, + Post => Keys'Result.Kind = Vec_Kind; + -- Keys, in either the original addition order, or in alphabetical order + + function Has_Key (This : Any; Key : Any) return Boolean with + Pre => This.Kind = Map_Kind; + + --------------- + -- Vectors -- + --------------- + + function Empty_Vec return Any + with Post => Empty_Vec'Result.Kind = Vec_Kind; + + procedure Append (This : in out Any; Elem : Any) with + Pre => This.Kind = Vec_Kind; + + function Append (This : Any; Elem : Any) return Any with + Pre => This.Kind = Vec_Kind; + + function First_Index (This : Any) return Universal_Integer with + Pre => This.Kind = Vec_Kind; + + function Last_Index (This : Any) return Universal_Integer with + Pre => This.Kind = Vec_Kind; + + function Head (This : Any) return Any with + Pre => This.Kind = Vec_Kind and then not This.Is_Empty; + + function Tail (This : Any) return Any with + Pre => This.Kind = Vec_Kind and then not This.Is_Empty, + Post => Tail'Result.Length = This.Length - 1; ---------------- -- Indexing -- ---------------- - function Get (This, Pos : Any) return Any with - Pre => This.Kind in Composite_Kinds - and then Pos.Kind in Scalar_Kinds | Vec_Kind; - -- Note this always returns a copy; for in place modification use Ref - - -- References and the like for indexing. Not really directly interesting. + -- Indexing a mutable vector one past the end creates a new nil element + -- there, allowing growth one element at a time. Vectors are 1-based. For + -- constant vectors the index must be valid. type Ref (Element : not null access Any) is limited null record with Implicit_Dereference => Element; @@ -114,59 +270,123 @@ package Yeison with Preelaborate is type Const (Element : not null access constant Any) is limited null record with Implicit_Dereference => Element; - function As_Ref (This : aliased Any) return Ref; - -- Not really needed by clients; used in tests - - -- We need to recreate references for the access discriminant to use the - -- proper type... - - function Const_Ref (This : aliased Any; Pos : Any) return Const with + function Reference (This : in out Any; Pos : Any) return Ref with Pre => Pos.Kind in Scalar_Kinds | Vec_Kind; - -- See notes on Reference below. Same applies, except for the - -- initialization of empty maps/vectors. + -- Pos may be a scalar, used as key/index, or a vector consumed one element + -- at a time (nested indexing). A nil This is auto-vivified into the proper + -- holder (vec if Pos is Int, map otherwise). + + function Get (This : Any; Pos : Any) return Any with + Pre => This.Kind in Composite_Kinds + and then Pos.Kind in Scalar_Kinds | Vec_Kind; + -- Always returns a copy; for in-place modification use Reference - function Reference (This : aliased Any; Pos : Any) return Ref with + function Constant_Reference (This : Any; Pos : Any) return Const with Pre => Pos.Kind in Scalar_Kinds | Vec_Kind; - -- Any may be a scalar, which will be used as key/index, or a vector that - -- will be consumed one element at a time. In YAML, keys can be complex - -- types, which is discouraged, and this is explicitly not supported. - -- - -- If This is invalid, the appropriate holder value will be created (vec or - -- map) depending on Any.Kind being Int or something else. If you want to - -- force either one, assign first an empty value. --------------- - -- Operators -- + -- Iterators -- --------------- - -- Cannot be instantiated here as Any must be private. Simply with and use - -- Yeison.Operators. + type Cursor (<>) is private; + + function Has_Element (Pos : Cursor) return Boolean; + + function First (This : Any) return Cursor; + + function Element (This : Any; Pos : Cursor) return Any; + + function Key (This : Any; Pos : Cursor) return Any; + -- The map key at the cursor; raises Constraint_Error for a vector cursor. - function To_Any (This : Impl.Any) return Any; - -- This should be private but it must be publicly visible by the nested - -- Operators. Another spill-over of trying to reuse for 12/22 versions. + package Iteration is new Ada.Iterator_Interfaces (Cursor, Has_Element); + + function Iterate (This : Any) return Iteration.Forward_Iterator'Class; + + function Constant_Reference (This : Any; Pos : Cursor) return Const; + + function Reference (This : in out Any; Pos : Cursor) return Ref; private Unimplemented : exception; - type Any is new Impl.Any with null record; - -- Must be private to avoid error with [] getting confused + package WWUStrings renames Ada.Strings.Wide_Wide_Unbounded; + subtype WWUString is WWUStrings.Unbounded_Wide_Wide_String; - package Charconv renames Ada.Characters.Conversions; + function U (S : Wide_Wide_String) return WWUString renames + Ada.Strings.Wide_Wide_Unbounded.To_Unbounded_Wide_Wide_String; - ----------- - -- Image -- - ----------- + function S (U : WWUString) return Text renames + Ada.Strings.Wide_Wide_Unbounded.To_Wide_Wide_String; - function Image (I : Big_Integers.Big_Integer) return Wide_Wide_String - is (Charconv.To_Wide_Wide_String (Big_Integers.To_String (I))); + type Any_Impl; - ----------- - -- Image -- - ----------- + type Any_Impl_Ptr is access Any_Impl; + -- Implementation in the body, for a self-referential type and to control + -- assignments via Controlled (when assigning through indexing). + + function Nil_Impl return Any_Impl_Ptr; + + type Any is new Ada.Finalization.Controlled with record + Impl : Any_Impl_Ptr := Nil_Impl; + end record with + Type_Invariant => Impl /= null; + + overriding procedure Adjust (This : in out Any); + + overriding procedure Finalize (This : in out Any); + + package Any_Maps is new Ada.Containers.Ordered_Maps (Any, Any); + + subtype Universal_Positive is + Universal_Integer range 1 .. Universal_Integer'Last; + + package Any_Vecs is new Ada.Containers.Vectors (Universal_Positive, Any); + + --------------- + -- Scalars -- + --------------- + + type Scalar_Data (Kind : Scalar_Kinds := Bool_Kind) is record + case Kind is + when Bool_Kind => Bool : Boolean; + when Int_Kind => Int : Big_Int; + when Real_Kind => Real : Reals.General_Real; + when Str_Kind => Str : WWUString; + end case; + end record; + + type Scalar is tagged record + Data : Scalar_Data; + end record; + + -- Cursor type for iteration + + type Cursor_Kind is (Invalid, Map_Cursor, Vec_Cursor); + + type Cursor (Kind : Cursor_Kind := Invalid) is record + case Kind is + when Invalid => null; + when Map_Cursor => Map_Pos : Any_Maps.Cursor; + when Vec_Cursor => Vec_Pos : Any_Vecs.Cursor; + end case; + end record; + + type Iterator is new Iteration.Forward_Iterator with record + Container : access constant Any; + end record; + + overriding function First (Object : Iterator) return Cursor; + + overriding function Next (Object : Iterator; + Position : Cursor) return Cursor; + + ----------------- + -- Nicer_Image -- + ----------------- - function Image (R : Big_Reals.Big_Real) return Wide_Wide_String - is (Charconv.To_Wide_Wide_String (Big_Reals.To_String (R))); + function Nicer_Image (R : Big_Real) return Wide_Wide_String + is (Yeison_Utils.Nicer_Real_Image (R'Wide_Wide_Image)); end Yeison; diff --git a/yeison_22/tests/alire.toml b/yeison_22/tests/alire.toml new file mode 100644 index 0000000..c07f72d --- /dev/null +++ b/yeison_22/tests/alire.toml @@ -0,0 +1,16 @@ +name = "yeison_tests" +description = "Tests for the built-in Alire test runner" +version = "0.0.0-test" + +[build-switches] +"*".ada_version = "Ada2022" + +[[depends-on]] +yeison = "*" + +[[pins]] +yeison = { path = ".." } + +[build-profiles] +yeison = "validation" +yeison_tests = "validation" diff --git a/yeison_22/tests/common/yeison_tests.ads b/yeison_22/tests/common/yeison_tests.ads new file mode 100644 index 0000000..0833f2c --- /dev/null +++ b/yeison_22/tests/common/yeison_tests.ads @@ -0,0 +1,23 @@ +pragma Ada_2022; +pragma Warnings (Off); +with Ada.Assertions; use Ada.Assertions; +-- Make Assert visible to children + +with Yeison; use Yeison; +with Yeison.Operators; use Yeison.Operators; + +package Yeison_Tests is + + pragma Warnings (On); + + -- The same nested structure as the Yeison_12 testsuite, but built with the + -- Ada 2022 literal and aggregate syntax instead of "+" constructors. + + function Sample return Yeison.Any + is (["one" => "one", + "two" => 2, + "three" => +[1, "two", 3], + "four" => ["4a" => 4], + "five" => 5.5]); + +end Yeison_Tests; diff --git a/yeison_22/tests/src/yeison_tests-comparisons.adb b/yeison_22/tests/src/yeison_tests-comparisons.adb new file mode 100644 index 0000000..67975d5 --- /dev/null +++ b/yeison_22/tests/src/yeison_tests-comparisons.adb @@ -0,0 +1,25 @@ +pragma Ada_2022; + +procedure Yeison_Tests.Comparisons is + S : Any renames Yeison_Tests.Sample; +begin + -- Equality with literals on the right-hand side (no Text/Int overloads + -- needed: the literal aspects make "one"/2 into Any). + Assert (S ("one") = "one", "any = string literal"); + Assert ("one" = S ("one"), "string literal = any (symmetric)"); + Assert (S ("two") = 2, "any = int literal"); + Assert (2 = S ("two"), "int literal = any (symmetric)"); + Assert (S ("five") = 5.5, "any = real literal"); + + Assert (not (S ("one") = 2), "different kinds are unequal"); + Assert (not (S ("one") = "two"), "different strings unequal"); + + -- Ordering: kinds order by their position, then by value + Assert (Any'(1) < Any'(2), "int ordering"); + Assert (Any'("a") < Any'("b"), "string ordering"); + Assert (Any'(True) < Any'(1), "bool kind precedes int kind"); + Assert (Precedes (Any'(1), Any'("z")), "int kind precedes str kind"); + + -- Whole-structure equality + Assert (Sample = Sample, "structural equality"); +end Yeison_Tests.Comparisons; diff --git a/yeison_22/tests/src/yeison_tests-crate.adb b/yeison_22/tests/src/yeison_tests-crate.adb new file mode 100644 index 0000000..63ebe29 --- /dev/null +++ b/yeison_22/tests/src/yeison_tests-crate.adb @@ -0,0 +1,50 @@ +pragma Ada_2022; + +procedure Yeison_Tests.Crate is + + URL : constant Text := "url"; + Commit : constant Text := "commit"; + + -- A realistic, deeply nested structure (an Alire crate manifest), written + -- entirely with literal/aggregate syntax. + + Crate : constant Yeison.Map := + ["name" => "alr", + "description" => "The Alire project command-line tool", + "version" => "1.2.0-dev", + "auto-gpr-with" => False, + "maintainers" => +["mosteo", "chouteau"], + + "depends-on" => + ["aaa" => "~0.2.3", + "ada_toml" => "~0.1", + "spdx" => "~0.2"], + + "pins" => + Map'["ada_toml" => [URL => "http://adatoml", Commit => "abcd"], + "spdx" => [URL => "http://spdx", Commit => "1234"]], + + "available" => + Map'["case(os)" => + Map'["linux" => True, + "..." => False]]]; + +begin + Assert (Crate.Kind = Map_Kind, "crate is a map"); + Assert (Crate ("name").As_Text = "alr", "crate name"); + Assert (Crate ("auto-gpr-with").Is_False, "boolean field"); + + Assert (Crate ("maintainers").Kind = Vec_Kind, "maintainers vector"); + Assert (Crate ("maintainers").Length = 2, "two maintainers"); + Assert (Crate ("maintainers") (1).As_Text = "mosteo", "first maintainer"); + + -- Deep nested access, chained and path forms + Assert (Crate ("depends-on") ("ada_toml").As_Text = "~0.1", + "nested dependency version"); + -- Index with string literals (a Text variable like URL is not a literal, + -- so the String_Literal aspect would not apply to it when indexing). + Assert (Crate ("pins") ("spdx") ("url").As_Text = "http://spdx", + "deeply nested pin url"); + Assert (Crate ("available" / "case(os)" / "linux").Is_True, + "path access to availability"); +end Yeison_Tests.Crate; diff --git a/yeison_22/tests/src/yeison_tests-image_formats.adb b/yeison_22/tests/src/yeison_tests-image_formats.adb new file mode 100644 index 0000000..f64d0e6 --- /dev/null +++ b/yeison_22/tests/src/yeison_tests-image_formats.adb @@ -0,0 +1,28 @@ +pragma Ada_2022; + +with Ada.Strings.UTF_Encoding.Wide_Wide_Strings; +use Ada.Strings.UTF_Encoding.Wide_Wide_Strings; + +procedure Yeison_Tests.Image_Formats is + + function "+" (T : Text) return String is (Encode (T)); + + M : constant Any := ["one" => 1]; + V : constant Any := +[1]; + S : constant Any := "hi"; +begin + -- Scalars + Assert (+Any'(1).Image = "1", "int image"); + Assert (+S.Image (JSON) = """hi""", "json string image is quoted"); + Assert (+True.Image (JSON) = "true", "json bool image"); + + -- Empty containers + Assert (+Empty_Map.Image (JSON) = "{}", "empty map json"); + Assert (+Empty_Vec.Image (JSON) = "[]", "empty vec json"); + + -- Compact one-element rendering + Assert (+M.Image (JSON, (Compact => True, others => <>)) = "{ ""one"": 1 }", + "compact json map"); + Assert (+V.Image (JSON, (Compact => True, others => <>)) = "[ 1 ]", + "compact json vec"); +end Yeison_Tests.Image_Formats; diff --git a/yeison_22/tests/src/yeison_tests-indexing.adb b/yeison_22/tests/src/yeison_tests-indexing.adb new file mode 100644 index 0000000..d6ab8fd --- /dev/null +++ b/yeison_22/tests/src/yeison_tests-indexing.adb @@ -0,0 +1,43 @@ +pragma Ada_2022; + +procedure Yeison_Tests.Indexing is + M : constant Any := ["a" => ["b" => 42]]; + V : constant Any := +[+[1, 2], +[3, 4]]; +begin + -- Nested map indexing, chained and path forms + Assert (M ("a") ("b").As_Int = 42, "chained map indexing"); + Assert (M ("a" / "b").As_Int = 42, "path map indexing"); + Assert (M (+["a", "b"]).As_Int = 42, "vector-path map indexing"); + + -- Nested vector indexing + Assert (V (1) (2).As_Int = 2, "chained vec indexing"); + Assert (V (2) (1).As_Int = 3, "chained vec indexing 2"); + Assert (V.Get (2 / 2).As_Int = 4, "path vec indexing"); + + -- Mutation through variable indexing (zero-copy, native) + declare + Map : Any; + begin + Map ("x") := "y"; + Assert (Map.Kind = Map_Kind, "auto-vivified map"); + Assert (Map ("x").As_Text = "y", "map mutation"); + Map ("x") := 1; -- overwrite, changing kind + Assert (Map ("x").As_Int = 1, "map overwrite"); + end; + + -- Deep nested mutation + declare + Deep : Any; + begin + Deep ("a") ("b") := 99; + Assert (Deep ("a") ("b").As_Int = 99, "deep nested mutation"); + end; + + -- Constant indexing returns a copy that does not alter the original + declare + Orig : constant Any := ["k" => 1]; + Copy : constant Any := Orig ("k"); + begin + Assert (Copy.As_Int = 1, "constant indexing copy"); + end; +end Yeison_Tests.Indexing; diff --git a/yeison_22/tests/src/yeison_tests-iterators.adb b/yeison_22/tests/src/yeison_tests-iterators.adb new file mode 100644 index 0000000..eebb8a6 --- /dev/null +++ b/yeison_22/tests/src/yeison_tests-iterators.adb @@ -0,0 +1,41 @@ +pragma Ada_2022; + +procedure Yeison_Tests.Iterators is + V : constant Any := +[10, 20, 30]; + M : constant Any := ["a" => 1, "b" => 2, "c" => 3]; +begin + -- "for E of Vec" yields the elements + declare + Sum : Big_Int := 0; + begin + for E of V loop + Sum := Sum + E.As_Int; + end loop; + Assert (Sum = 60, "vector iteration sum"); + end; + + -- "for E of Map" yields the values + declare + Sum : Big_Int := 0; + begin + for E of M loop + Sum := Sum + E.As_Int; + end loop; + Assert (Sum = 6, "map values iteration sum"); + end; + + -- Cursor-based traversal with Key/Element over a map + declare + It : constant Iteration.Forward_Iterator'Class := Iterate (M); + Count : Natural := 0; + C : Cursor := It.First; + begin + while Has_Element (C) loop + Count := Count + 1; + -- Key/Element consistency: M (Key) = Element + Assert (M (M.Key (C)) = M.Element (C), "key/element consistency"); + C := It.Next (C); + end loop; + Assert (Count = 3, "three map entries"); + end; +end Yeison_Tests.Iterators; diff --git a/yeison_22/tests/src/yeison_tests-literals.adb b/yeison_22/tests/src/yeison_tests-literals.adb new file mode 100644 index 0000000..68de0df --- /dev/null +++ b/yeison_22/tests/src/yeison_tests-literals.adb @@ -0,0 +1,24 @@ +pragma Ada_2022; + +procedure Yeison_Tests.Literals is + B : constant Any := True; + I : constant Any := 42; + R : constant Any := 3.5; + S : constant Any := "hello"; + N : constant Any := Nil; +begin + Assert (B.Kind = Bool_Kind, "bool literal kind"); + Assert (B.Is_True, "bool literal value"); + + Assert (I.Kind = Int_Kind, "int literal kind"); + Assert (I.As_Int = 42, "int literal value"); + + Assert (R.Kind = Real_Kind, "real literal kind"); + Assert (R.As_Real_Float = 3.5, "real literal value"); + + Assert (S.Kind = Str_Kind, "string literal kind"); + Assert (S.As_Text = "hello", "string literal value"); + + Assert (N.Kind = Nil_Kind, "nil kind"); + Assert (not N.Has_Value, "nil has no value"); +end Yeison_Tests.Literals; diff --git a/yeison_22/tests/src/yeison_tests-maps.adb b/yeison_22/tests/src/yeison_tests-maps.adb new file mode 100644 index 0000000..c634d0d --- /dev/null +++ b/yeison_22/tests/src/yeison_tests-maps.adb @@ -0,0 +1,44 @@ +pragma Ada_2022; + +procedure Yeison_Tests.Maps is + Empty : constant Any := []; + M : constant Any := ["one" => 1, "two" => "two"]; +begin + Assert (Empty.Kind = Map_Kind, "[] is an empty map"); + Assert (Empty.Is_Empty, "empty map is empty"); + + Assert (M.Kind = Map_Kind, "map aggregate kind"); + Assert (M.Length = 2, "map length"); + Assert (M.Has_Key ("one"), "has key one"); + Assert (not M.Has_Key ("nope"), "missing key"); + + Assert (M ("one").As_Int = 1, "value of one"); + Assert (M ("two").As_Text = "two", "value of two"); + + -- Keys, in insertion order + declare + K : constant Any := M.Keys; + begin + Assert (K.Kind = Vec_Kind, "keys is a vector"); + Assert (K.Length = 2, "two keys"); + Assert (K (1).As_Text = "one", "first key"); + Assert (K (2).As_Text = "two", "second key"); + end; + + -- Functional insert returns a copy, original unchanged + declare + M2 : constant Any := M.Insert ("three", 3); + begin + Assert (M2.Length = 3, "inserted copy has 3"); + Assert (M.Length = 2, "original still 2"); + end; + + -- In-place procedural insert + declare + V : Any := ["a" => 1]; + begin + V.Insert ("b", 2); + Assert (V.Length = 2, "in-place insert"); + Assert (V ("b").As_Int = 2, "in-place value"); + end; +end Yeison_Tests.Maps; diff --git a/yeison_22/tests/src/yeison_tests-scalars.adb b/yeison_22/tests/src/yeison_tests-scalars.adb new file mode 100644 index 0000000..a6affc7 --- /dev/null +++ b/yeison_22/tests/src/yeison_tests-scalars.adb @@ -0,0 +1,32 @@ +pragma Ada_2022; + +procedure Yeison_Tests.Scalars is + B : constant Any := True; + I : constant Any := 7; + R : constant Any := 2.5; + S : constant Any := "text"; +begin + -- Direct accessors + Assert (B.As_Bool = Standard.True, "As_Bool"); + Assert (I.As_Int = 7, "As_Int"); + Assert (R.As_Real_Float = 2.5, "As_Real_Float"); + Assert (S.As_Text = "text", "As_Text"); + Assert (S.As_UTF_8 = "text", "As_UTF_8"); + + -- Get renamings (resolved by result type) + declare + GI : constant Big_Int := I.Get; + GT : constant Text := S.Get; + begin + Assert (GI = 7, "Get -> Big_Int"); + Assert (GT = "text", "Get -> Text"); + end; + + -- The separate Scalar view + declare + Sc : constant Scalar := I.As_Scalar; + begin + Assert (Sc.Kind = Int_Kind, "scalar kind"); + Assert (Sc.As_Integer = 7, "scalar integer"); + end; +end Yeison_Tests.Scalars; diff --git a/yeison_22/tests/src/yeison_tests-vectors.adb b/yeison_22/tests/src/yeison_tests-vectors.adb new file mode 100644 index 0000000..ca7d44d --- /dev/null +++ b/yeison_22/tests/src/yeison_tests-vectors.adb @@ -0,0 +1,52 @@ +pragma Ada_2022; + +procedure Yeison_Tests.Vectors is + Homo : constant Any := +[1, 2, 3]; + Hetero : constant Any := +[1, "two", 3.0]; +begin + Assert (Homo.Kind = Vec_Kind, "vector kind"); + Assert (Homo.Length = 3, "vector length"); + Assert (Homo.First_Index = 1, "1-based first index"); + Assert (Homo.Last_Index = 3, "last index"); + Assert (Homo (1).As_Int = 1, "first element"); + Assert (Homo (3).As_Int = 3, "third element"); + + Assert (Hetero (2).As_Text = "two", "heterogeneous element"); + Assert (Hetero (3).As_Real_Float = 3.0, "real element"); + + -- Head/Tail + Assert (Homo.Head.As_Int = 1, "head"); + Assert (Homo.Tail.Length = 2, "tail length"); + declare + T : constant Any := Homo.Tail; + begin + Assert (T (1).As_Int = 2, "tail first"); + end; + + -- Append (functional and procedural) + declare + V : Any := +[1]; + begin + V.Append (2); + Assert (V.Length = 2, "appended length"); + Assert (V (2).As_Int = 2, "appended value"); + + declare + V3 : constant Any := V.Append (3); + begin + Assert (V3.Length = 3, "functional append copy"); + Assert (V.Length = 2, "original unchanged"); + end; + end; + + -- Grow one element at a time via indexing (1 past the end) + declare + V : Any; + begin + V (1) := "one"; + V (2) := "two"; + Assert (V.Kind = Vec_Kind, "auto-vivified vector"); + Assert (V.Length = 2, "grown to 2"); + Assert (V (1).As_Text = "one", "grown element 1"); + end; +end Yeison_Tests.Vectors; diff --git a/yeison_22/tests/yeison_tests.gpr b/yeison_22/tests/yeison_tests.gpr new file mode 100644 index 0000000..4c58b0a --- /dev/null +++ b/yeison_22/tests/yeison_tests.gpr @@ -0,0 +1,19 @@ +with "config/yeison_tests_config.gpr"; +with "config/yeison_tests_list_config.gpr"; + +project Yeison_Tests is + for Source_Dirs use ("src/**", "common/", "config/"); + for Object_Dir use "obj/" & Yeison_Tests_Config.Build_Profile; + for Create_Missing_Dirs use "True"; + for Exec_Dir use "bin"; + for Main use Yeison_Tests_List_Config.Test_Files; + + package Compiler is + for Default_Switches ("Ada") use + Yeison_Tests_Config.Ada_Compiler_Switches; + end Compiler; + + package Binder is + for Switches ("Ada") use ("-Es"); -- Symbolic traceback + end Binder; +end Yeison_Tests; From 98c21e289aca5005059ca86c4630729c76f93e76 Mon Sep 17 00:00:00 2001 From: "Alejandro R. Mosteo" Date: Sun, 31 May 2026 19:39:55 +0200 Subject: [PATCH 2/4] Fully independent Yeison 2022 --- yeison_12/src/yeison_generic-operators.adb | 114 -- yeison_12/src/yeison_generic-operators.ads | 45 - yeison_12/src/yeison_generic.adb | 1028 ----------------- yeison_12/src/yeison_generic.ads | 405 ------- yeison_22/src/yeison.adb | 18 + yeison_22/src/yeison.ads | 11 +- yeison_22/test/.gitignore | 4 - yeison_22/test/alire.toml | 24 - yeison_22/test/src/test.adb | 128 -- yeison_22/test/src/test_crate.adb | 8 - yeison_22/test/src/test_crate.ads | 36 - yeison_22/test/src/test_indexing.adb | 111 -- yeison_22/test/src/test_indexing.ads | 3 - yeison_22/test/test.gpr | 23 - .../tests/src/yeison_tests-image_formats.adb | 2 +- yeison_dev.gpr | 4 +- 16 files changed, 28 insertions(+), 1936 deletions(-) delete mode 100644 yeison_12/src/yeison_generic-operators.adb delete mode 100644 yeison_12/src/yeison_generic-operators.ads delete mode 100644 yeison_12/src/yeison_generic.adb delete mode 100644 yeison_12/src/yeison_generic.ads delete mode 100644 yeison_22/test/.gitignore delete mode 100644 yeison_22/test/alire.toml delete mode 100644 yeison_22/test/src/test.adb delete mode 100644 yeison_22/test/src/test_crate.adb delete mode 100644 yeison_22/test/src/test_crate.ads delete mode 100644 yeison_22/test/src/test_indexing.adb delete mode 100644 yeison_22/test/src/test_indexing.ads delete mode 100644 yeison_22/test/test.gpr diff --git a/yeison_12/src/yeison_generic-operators.adb b/yeison_12/src/yeison_generic-operators.adb deleted file mode 100644 index 26b69a6..0000000 --- a/yeison_12/src/yeison_generic-operators.adb +++ /dev/null @@ -1,114 +0,0 @@ -package body Yeison_Generic.Operators is - - -- This whole package is an attempt at working around a bug in GNAT 10/11 - -- related to case records in nested generic packages. Or something. - - --------- - -- "/" -- - --------- - - function "/" (L, R : Client_Any) return Client_Any is - begin - if L.Kind in Scalar_Kinds then - return Result : Client_Any := Empty_Vec do - Result.Append (L); - Result.Append (R); - end return; - elsif L.Kind in Vec_Kind then - return Result : Client_Any := L do - Result.Append (R); - end return; - else - raise Constraint_Error with - "Cannot append using ""/"" when left operator is: " - & L.Kind'Image; - end if; - end "/"; - - ---------- - -- Make -- - ---------- - - package body Make is - - --------- - -- Nil -- - --------- - - function Nil return Client_Any - is (To_Any (Base.New_Nil)); - - ------------ - -- Scalar -- - ------------ - - function Scalar (This : Yeison_Generic.Scalar) return Client_Any - is - Pre : constant Any'Class := - (case This.Data.Kind is - when Bool_Kind => Base.New_Bool (This.Data.Bool), - when Int_Kind => Base.New_Int (This.Data.Int), - when Real_Kind => Base.New_Real (This.Data.Real), - when Str_Kind => Base.New_Text (S (This.Data.Str))); - begin - return To_Any (Any (Pre)); - end Scalar; - - ----------- - -- False -- - ----------- - - function False return Client_Any - is (Make.Scalar (Scalars.New_Bool (False))); - - ---------- - -- True -- - ---------- - - function True return Client_Any - is (Make.Scalar (Scalars.New_Bool (True))); - - ---------- - -- Bool -- - ---------- - - function Bool (This : Boolean) return Client_Any - is (Make.Scalar (Scalars.New_Bool (This))); - - --------- - -- Int -- - --------- - - function Int (This : Int_Type) return Client_Any - is (Make.Scalar (Scalars.New_Int (This))); - - ---------- - -- Real -- - ---------- - - function Real (This : Real_Type) return Client_Any - is (Make.Scalar (Scalars.New_Real (This))); - - --------- - -- Str -- - --------- - - function Str (This : Wide_Wide_String) return Client_Any - is (Make.Scalar (Scalars.New_Text (This))); - - end Make; - - --------- - -- Vec -- - --------- - - function Vec (This : Any_Array) return Client_Any is - begin - return Result : Client_Any := Empty_Vec do - for Elem of This loop - Result.Append (Elem); - end loop; - end return; - end Vec; - -end Yeison_Generic.Operators; diff --git a/yeison_12/src/yeison_generic-operators.ads b/yeison_12/src/yeison_generic-operators.ads deleted file mode 100644 index 5f71fbc..0000000 --- a/yeison_12/src/yeison_generic-operators.ads +++ /dev/null @@ -1,45 +0,0 @@ ---------------- --- Operators -- ---------------- - -generic - type Client_Any is new Yeison_Generic.Any with private; - with function To_Any (This : Yeison_Generic.Any) return Client_Any is <>; -package Yeison_Generic.Operators with Preelaborate is - - --------- - -- "/" -- - --------- - - function "/" (L, R : Client_Any) return Client_Any with - Pre => L.Kind in Scalar_Kinds | Vec_Kind, - Post => "/"'Result.Kind = Vec_Kind; - - -- Temporary workaround until both Add_Named and Add_Unnamed can be used - -- simultaneously on the same type. It's convenient having it here so - -- "+" becomes visible with the rest. - - type Any_Array is array (Positive range <>) of Client_Any; - - function Vec (This : Any_Array) return Client_Any with - Post => Vec'Result.Kind = Vec_Kind; - - ---------- - -- Make -- - ---------- - - package Make is - function Nil return Client_Any; - - function True return Client_Any; - function False return Client_Any; - - function Bool (This : Boolean) return Client_Any; - function Int (This : Int_Type) return Client_Any; - function Real (This : Real_Type) return Client_Any; - function Str (This : Text) return Client_Any; - - function Scalar (This : Yeison_Generic.Scalar) return Client_Any; - end Make; - -end Yeison_Generic.Operators; diff --git a/yeison_12/src/yeison_generic.adb b/yeison_12/src/yeison_generic.adb deleted file mode 100644 index d6fc80d..0000000 --- a/yeison_12/src/yeison_generic.adb +++ /dev/null @@ -1,1028 +0,0 @@ -with Ada.Characters.Conversions; -with Ada.Characters.Wide_Wide_Latin_1; -with Ada.Strings.Wide_Wide_Fixed; -with Ada.Tags; use Ada.Tags; -with Ada.Unchecked_Deallocation; - -pragma Warnings (Off); -with GNAT.IO; use GNAT.IO; -pragma Warnings (On); - -with Yeison_Utils; - -package body Yeison_Generic is - - package Fixed renames Ada.Strings.Wide_Wide_Fixed; - - use type Ada.Containers.Count_Type; - use all type Ada.Strings.Trim_End; - - subtype Any_Parent is Ada.Finalization.Controlled; - - type Any_Impl (Kind : Kinds := Bool_Kind) is record - case Kind is - when Nil_Kind => null; - - when Scalar_Kinds => - Val : Scalar_Data (Kind); - - when Map_Kind => - Map : Any_Maps.Map; - Keys : Any_Vecs.Vector; - -- Keys, in the order in which they were added - - when Vec_Kind => - Vec : Any_Vecs.Vector; - end case; - end record - with Dynamic_Predicate => - (if Any_Impl.Kind = Map_Kind then Map.Length = Keys.Length); - - --------- - -- "=" -- - --------- - - function "=" (L, R : Any) return Boolean - is (L.Impl.all = R.Impl.all); - - function "=" (L : Any; R : Text) return Boolean - is (L.Kind = Str_Kind and then L.As_Text = R); - - -------------- - -- Nil_Impl -- - -------------- - - function Nil_Impl return Any_Impl_Ptr - is (new Any_Impl'(Kind => Nil_Kind)); - - function Kind (This : Scalar) return Scalar_Kinds is (This.Data.Kind); - - function As_Boolean (This : Scalar) return Boolean is (This.Data.Bool); - function As_Integer (This : Scalar) return Int_Type is (This.Data.Int); - function As_Real (This : Scalar) return Real_Type is (This.Data.Real); - function As_Text (This : Scalar) return Text - is (WWUStrings.To_Wide_Wide_String (This.Data.Str)); - - ---------- - -- Base -- - ---------- - - package body Base is - - function New_Nil return Any - is (Any'(Any_Parent with Impl => Nil_Impl)); - - function New_Bool (Val : Boolean) return Any - is (Any'(Any_Parent with Impl => - new Any_Impl'(Bool_Kind, (Bool_Kind, Val)))); - - function New_Int (Val : Int_Type) return Any - is (Any'(Any_Parent with Impl => - new Any_Impl'(Int_Kind, (Int_Kind, Val)))); - - function New_Real (Val : Real_Type) return Any - is (Any'(Any_Parent with Impl => - new Any_Impl'(Real_Kind, (Real_Kind, Val)))); - - function New_Text (Val : Text) return Any - is (Any'(Any_Parent with Impl => - new Any_Impl'(Str_Kind, (Str_Kind, U (Val))))); - - end Base; - - ------------- - -- Scalars -- - ------------- - - package body Scalars is - - ----------------- - -- New_Boolean -- - ----------------- - - function New_Bool (Val : Boolean) return Scalar - is (Data => (Kind => Bool_Kind, - Bool => Val)); - - ------------- - -- New_Int -- - ------------- - - function New_Int (Val : Int_Type) return Scalar - is (Data => (Kind => Int_Kind, - Int => Val)); - - -------------- - -- New_Real -- - -------------- - - function New_Real (Val : Real_Type) return Scalar - is (Data => (Kind => Real_Kind, - Real => Val)); - - -------------- - -- New_Text -- - -------------- - - function New_Text (Val : Text) return Scalar - is (Data => (Kind => Str_Kind, - Str => U (Val))); - - end Scalars; - - --------- - -- "<" -- - --------- - - function "<" (L, R : Any_Impl) return Boolean is - use type WWUString; - - ------------------ - -- Compare_Maps -- - ------------------ - - function Compare_Maps return Boolean is - -- Compare keys in order - L_Cursor : Any_Maps.Cursor := L.Map.First; - R_Cursor : Any_Maps.Cursor := R.Map.First; - begin - while Any_Maps.Has_Element (L_Cursor) - and then Any_Maps.Has_Element (R_Cursor) - loop - declare - L_Key : Any'Class renames Any_Maps.Key (L_Cursor); - R_Key : Any'Class renames Any_Maps.Key (R_Cursor); - begin - if L_Key < R_Key then - return True; - elsif R_Key < L_Key then - return False; - end if; - - -- Keys are equal, compare values - declare - L_Value : - Any'Class renames Any_Maps.Element (L_Cursor); - R_Value : - Any'Class renames Any_Maps.Element (R_Cursor); - begin - if L_Value < R_Value then - return True; - elsif R_Value < L_Value then - return False; - end if; - end; - end; - - Any_Maps.Next (L_Cursor); - Any_Maps.Next (R_Cursor); - end loop; - - -- If L is shorter than R, it is less - if Any_Maps.Has_Element (R_Cursor) then - return True; - end if; - - -- If R is shorter than L, L is not less than R - if Any_Maps.Has_Element (L_Cursor) then - return False; - end if; - - -- If we get here, all elements were equal and maps are same length - return False; - end Compare_Maps; - - ------------------ - -- Compare_Vecs -- - ------------------ - - function Compare_Vecs return Boolean is - -- Compare elements in order - begin - for I in L.Vec.First_Index .. L.Vec.Last_Index loop - exit when I > R.Vec.Last_Index; - declare - L_Elem : Any'Class renames L.Vec (I); - R_Elem : Any'Class renames R.Vec (I); - begin - if L_Elem < R_Elem then - return True; - elsif R_Elem < L_Elem then - return False; - end if; - end; - end loop; - - -- If L is shorter than R, it is less - if L.Vec.Last_Index < R.Vec.Last_Index then - return True; - end if; - - -- If we get here, all elements were equal - return False; - end Compare_Vecs; - - begin - if L.Kind < R.Kind then - return True; - elsif R.Kind < L.Kind then - return False; - end if; - - -- Both the same - - case L.Kind is - when Nil_Kind => return False; - when Bool_Kind => return L.Val.Bool < R.Val.Bool; - when Int_Kind => return L.Val.Int < R.Val.Int; - when Real_Kind => return L.Val.Real < R.Val.Real; - when Str_Kind => return L.Val.Str < R.Val.Str; - when Map_Kind => return Compare_Maps; - when Vec_Kind => return Compare_Vecs; - end case; - end "<"; - - --------------- - -- As_Scalar -- - --------------- - - function As_Scalar (This : Any'Class) return Scalar - is (Scalar'(Data => This.Impl.Val)); - - ------------- - -- As_Bool -- - ------------- - - function As_Bool (This : Any) return Boolean - is (This.Impl.Val.Bool); - - ------------ - -- As_Int -- - ------------ - - function As_Int (This : Any) return Int_Type - is (This.Impl.Val.Int); - - ------------- - -- As_Real -- - ------------- - - function As_Real (This : Any) return Real_Type - is (This.Impl.Val.Real); - - ------------- - -- As_Text -- - ------------- - - function As_Text (This : Any) return Text - is (Ada.Strings.Wide_Wide_Unbounded.To_Wide_Wide_String - (This.Impl.Val.Str)); - - -------------- - -- As_UTF_8 -- - -------------- - - function As_UTF_8 (This : Any) return String - is (Yeison_Utils.Encode (This.As_Text)); - - ---------------- - -- As_Latin_1 -- - ---------------- - - function As_Latin_1 (This : Any) return String - is (Ada.Characters.Conversions.To_String (This.As_Text)); - - --------------- - -- Empty_Map -- - --------------- - - function Empty_Map return Any - is (Ada.Finalization.Controlled with - Impl => new Any_Impl'(Kind => Map_Kind, others => <>)); - - --------------- - -- Empty_Vec -- - --------------- - - function Empty_Vec return Any - is (Ada.Finalization.Controlled with - Impl => new Any_Impl'(Kind => Vec_Kind, others => <>)); - - ----------------- - -- First_Index -- - ----------------- - - function First_Index (This : Any) return Universal_Integer is - begin - return Universal_Integer (This.Impl.Vec.First_Index); - end First_Index; - - ---------------- - -- Last_Index -- - ---------------- - - function Last_Index (This : Any) return Universal_Integer is - begin - return Universal_Integer (This.Impl.Vec.Last_Index); - end Last_Index; - - ---------------- - -- JSON_Quote -- - ---------------- - - function JSON_Quote (Str : Text) return Text is - begin - return '"' & Yeison_Utils.JSON_Escape (Str) & '"'; - end JSON_Quote; - - ----------- - -- Image -- - ----------- - - function Image (This : Any'Class; - Format : Image_Formats := Ada_Like; - Options : Image_Options := (others => <>)) - return Text - is - use Ada.Strings.Wide_Wide_Unbounded; - function "+" (S : Wide_Wide_String) return WWUString - renames To_Unbounded_Wide_Wide_String; - pragma Unreferenced ("+"); - - ------------------ - -- Scalar_Image -- - ------------------ - - function Scalar_Image (This : Any'Class) return Text - is (case This.Kind is - when Bool_Kind => - (if This.Impl.Val.Bool then "true" else "false"), - when Int_Kind => - Fixed.Trim (Image (This.Impl.Val.Int), Side => Both), - when Real_Kind => - Fixed.Trim (Image (This.Impl.Val.Real), Side => Both), - when Str_Kind => - (case Format is - when Ada_Like => - To_Wide_Wide_String (This.Impl.Val.Str), - when JSON => - JSON_Quote (To_Wide_Wide_String (This.Impl.Val.Str))), - when Nonscalar_Kinds => - raise Program_Error with "not a scalar: " & This.Kind'Image - ); - - Result : WWUString; - - --------------------- - -- Empty_Map_Image -- - --------------------- - - function Empty_Map_Image return Text - is (case Format is - when Ada_Like => "[=>]", - when JSON => "{}"); - - -------------- - -- Map_Open -- - -------------- - - function Map_Open return Text - is (case Format is - when Ada_Like => "[", - when JSON => "{"); - - --------------- - -- Map_Close -- - --------------- - - function Map_Close return Text - is (case Format is - when Ada_Like => "]", - when JSON => "}"); - - --------------- - -- Map_Arrow -- - --------------- - - function Map_Arrow return Text - is (case Format is - when Ada_Like => " => ", - when JSON => ": "); - - --------------------- - -- Empty_Vec_Image -- - --------------------- - - function Empty_Vec_Image return Text - is (case Format is - when Ada_Like => "[,]", - when JSON => "[]"); - - -------------- - -- Vec_Open -- - -------------- - - function Vec_Open return Text - is (case Format is - when Ada_Like => "[", - when JSON => "["); - - --------------- - -- Vec_Close -- - --------------- - - function Vec_Close return Text - is (case Format is - when Ada_Like => "]", - when JSON => "]"); - - -------------- - -- Traverse -- - -------------- - - procedure Traverse (This : Any'Class; - Prefix : Text; - Contd : Boolean := False) - is - NL : constant Text := "" & Ada.Characters.Wide_Wide_Latin_1.LF; - Tab : constant Text := - (case Format is - when Ada_Like => " ", - when JSON => " "); - -- function WS (Str : Text) return Text -- Whitespace of same length - -- is (1 .. Str'Length => ' '); - begin - case This.Kind is - when Nil_Kind => - Append (Result, (if Contd then Text'("") else Prefix) & "null"); - - when Scalar_Kinds => - Append (Result, - (if Contd then Text'("") else Prefix) - & Scalar_Image (This)); - - when Map_Kind => - declare - C_Map : Any_Maps.Cursor := This.Impl.Map.First; - C_Vec : Any_Vecs.Cursor := This.Impl.Keys.First; - use Any_Maps; - use Any_Vecs; - Abbr : constant Boolean := - Options.Compact and then This.Impl.Map.Length in 1; - begin - if This.Impl.Map.Is_Empty then - Append (Result, - (if Contd then "" else Prefix) & Empty_Map_Image); - return; - end if; - - Append (Result, - (if Contd then "" else Prefix) - & Map_Open - & (if Abbr then " " else NL)); - - while (if Options.Ordered_Keys - then Any_Maps.Has_Element (C_Map) - else Any_Vecs.Has_Element (C_Vec)) - loop - Append (Result, - (if Abbr then " " else Prefix & Tab) - & (if Options.Ordered_Keys - then Any_Maps.Key (C_Map) - .Image (Format, Options) - else Any_Vecs.Element (C_Vec) - .Image (Format, Options)) - & Map_Arrow); - -- TODO: the above key image should be prefixed in case - -- we are using an object for indexing. - - Traverse ((if Options.Ordered_Keys - then This.Impl.Map.Constant_Reference (C_Map) - else This.Impl.Map.Constant_Reference - (This.Impl.Map.Find - (Any_Vecs.Element (C_Vec)))), - Prefix & Tab, - Contd => True); - - if (if Options.Ordered_Keys - then Any_Maps.Has_Element (Next (C_Map)) - else Any_Vecs.Has_Element (Next (C_Vec))) - then - Append (Result, ","); - end if; - - if not Abbr then - Append (Result, NL); - end if; - - if Options.Ordered_Keys then - Next (C_Map); - else - Next (C_Vec); - end if; - end loop; - - Append (Result, - (if Abbr then " " else Prefix) & Map_Close); - end; - - when Vec_Kind => - declare - Abbr : constant Boolean := - Options.Compact and then This.Impl.Vec.Length in 1; - I : Natural := 0; - begin - if This.Impl.Vec.Is_Empty then - Append (Result, - (if Contd then "" else Prefix) - & Empty_Vec_Image); - return; - end if; - - Append (Result, - (if Contd then "" else Prefix) - & Vec_Open - & (if Abbr then " " else NL)); - - for E of This.Impl.Vec loop - Traverse (E, - Prefix & Tab, - Contd => Abbr); - I := I + 1; - Append (Result, - (if I = Natural (This.Impl.Vec.Length) - then "" - else ",") - & (if Abbr then " " else NL)); - end loop; - Append (Result, - (if Abbr then "" else Prefix) - & Vec_Close); - end; - end case; - end Traverse; - - begin - Traverse (This, ""); - - return To_Wide_Wide_String (Result); - end Image; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (This : Any) return Boolean - is (case This.Kind is - when Nil_Kind => True, - when Map_Kind => This.Impl.Map.Is_Empty, - when Vec_Kind => This.Impl.Vec.Is_Empty, - when others => - raise Constraint_Error - with "not a collection: " & This.Kind'Image); - - --------------- - -- Has_Value -- - --------------- - - function Has_Value (This : Any) return Boolean - is (This.Kind /= Nil_Kind); - - ---------- - -- Kind -- - ---------- - - function Kind (This : Any) return Kinds - is (This.Impl.Kind); - - ------------ - -- Length -- - ------------ - - function Length (This : Any) return Universal_Integer - is (case This.Kind is - when Map_Kind => Universal_Integer (This.Impl.Map.Length), - when Vec_Kind => Universal_Integer (This.Impl.Vec.Length), - when others => - raise Constraint_Error - with "not a collection: " & This.Kind'Image); - - --------- - -- "<" -- - --------- - - function "<" (L, R : Any) return Boolean is - begin - if L.Kind < R.Kind then - return True; - elsif R.Kind < L.Kind then - return False; - end if; - - return L.Impl.all < R.Impl.all; - end "<"; - - ------------ - -- Adjust -- - ------------ - - overriding procedure Adjust (This : in out Any) is - begin - This.Impl := new Any_Impl'(This.Impl.all); - end Adjust; - - ------------ - -- Append -- - ------------ - - procedure Append (This : in out Any; Elem : Any) is - begin - This.Impl.Vec.Append (Elem); - end Append; - - ------------ - -- Append -- - ------------ - - function Append (This : Any; Elem : Any) return Any is - begin - return Result : Any := This do - Result.Append (Elem); - end return; - end Append; - - ----------------- - -- Insert_Impl -- - ----------------- - - procedure Insert_Impl (Impl : in out Any_Impl; - Key : Any'Class; - Value : Any'Class; - Replace : Boolean := False) - is - begin - if Replace and then Impl.Map.Contains (Key) then - Impl.Map.Replace (Key, Value); - -- We don't need to update the Keys vector since the key already - -- exists. - else - Impl.Map.Insert (Key, Value); - Impl.Keys.Append (Key); - end if; - end Insert_Impl; - - ------------ - -- Insert -- - ------------ - - procedure Insert (This : in out Any; - Key : Any; - Value : Any; - Replace : Boolean := False) - is - begin - Insert_Impl (This.Impl.all, Key, Value, Replace); - end Insert; - - ------------ - -- Insert -- - ------------ - - function Insert (This : Any; - Key : Any; - Value : Any; - Replace : Boolean := False) - return Any - is - begin - return Result : Any := This do - Result.Insert (Key, Value, Replace); - end return; - end Insert; - - -------------- - -- Finalize -- - -------------- - - overriding procedure Finalize (This : in out Any) is - procedure Free is - new Ada.Unchecked_Deallocation (Any_Impl, Any_Impl_Ptr); - begin - Free (This.Impl); - end Finalize; - - ---------------- - -- References -- - ---------------- - - package body References is - - ---------- - -- Keys -- - ---------- - - function Keys (This : Any; Ordered : Boolean := False) return Any is - begin - return Result : Any := Empty_Vec do - if Ordered then - for I in This.Impl.Map.Iterate loop - Result.Append (To_Any (Base_Any (Any_Maps.Key (I)))); - end loop; - else - for Key of This.Impl.Keys loop - Result.Append (To_Any (Base_Any (Key))); - end loop; - end if; - end return; - end Keys; - - ------------- - -- Has_Key -- - ------------- - - function Has_Key (This : Any; Key : Any) return Boolean is - begin - return This.Impl.Map.Contains (Key); - end Has_Key; - - ---------- - -- Head -- - ---------- - - function Head (This : Any) return Any - is (Any (This.Impl.Vec.First_Element)); - - ---------- - -- Tail -- - ---------- - - function Tail (This : Any) return Any is - begin - return Result : Any := To_Any (Empty_Vec) do - for I in This.Impl.Vec.First_Index + 1 .. This.Impl.Vec.Last_Index - loop - Result.Append (Any (This.Impl.Vec (I).Element.all)); - end loop; - end return; - end Tail; - - ---------- - -- Self -- - ---------- - - function Self (This : Yeison_Generic.Any'Class) return Ref - is (if This in Any - then Any (This)'Unrestricted_Access - else raise Program_Error with External_Tag (This'Tag)); - - ---------- - -- Wrap -- - ---------- - - function Wrap (This : Yeison_Generic.Any'Class) return Any - is (if This in Any - then Any (This) - else To_Any (Yeison_Generic.Any (This))); - pragma Unreferenced (Wrap); - - --------- - -- Get -- - --------- - - function Get (This : Any; Pos : Any) return Any - is (Reference (This, Pos).all); - - --------------- - -- Reference -- - --------------- - - function Reference (This : Any; Pos : Any) return Ref - is - - ---------------------- - -- Constraint_Error -- - ---------------------- - - procedure Constraint_Error (Msg : String; Pos : Any'Class) is - begin - raise Standard.Constraint_Error - with "cannot index " & Msg & " when index is " - & Yeison_Utils.Encode (Pos.Image); - end Constraint_Error; - - ------------------- - -- Ref_By_Scalar -- - ------------------- - - function Ref_By_Scalar (This : Any; - Pos : Any) - return Ref - is - subtype Univ is Universal_Integer; - begin - - -- Initialize empty vec/map if needed - - if This.Is_Nil then - case Pos.Kind is - when Int_Kind => - Self (This).all := To_Any (Empty_Vec); - when Map_Kind => - Constraint_Error ("null Any with map", Pos); - when others => - Self (This).all := To_Any (Empty_Map); - end case; - end if; - - -- Access the position. At this point Pos must be a scalar - - case This.Kind is - when Nil_Kind | Scalar_Kinds => - -- Do not allow indexing an scalar at all - Constraint_Error ("non-composite value", Pos); - return null; - - when Map_Kind => - -- TODO: use cursors to avoid double lookup - - -- Put_Line ("pos: " & Pos.Image); - -- Put_Line (This.Impl.Map.Contains (Pos)'Wide_Wide_Image); - -- if This.Impl.Map.Contains (Pos) then - -- Put_Line (This.Impl.Map (Pos).Image); - -- end if; - - if not This.Impl.Map.Contains (Pos) then - Insert_Impl (This.Impl.all, Pos, To_Any (Base.New_Nil)); - end if; - - return Self - (This.Impl.Map.Constant_Reference (Pos).Element.all); - - when Vec_Kind => - declare - Index : constant Univ := To_Integer (Pos.As_Int); - begin - if Index <= 0 then - Constraint_Error - ("vector with non-positive index " & Index'Image, Pos); - end if; - - if Univ (This.Impl.Vec.Length) + 1 < Index then - Constraint_Error - ("vector beyond 'length + 1 when 'length =" - & This.Impl.Vec.Length'Image, Pos); - end if; - - if Univ (This.Impl.Vec.Length) < Index then - This.Impl.Vec.Append (To_Any (Base.New_Nil)); - end if; - - return Self (This.Impl.Vec.Constant_Reference - (Index).Element.all); - end; - end case; - end Ref_By_Scalar; - - begin - case Pos.Kind is - when Nil_Kind => - Constraint_Error ("with null index", Pos); - return null; - - when Map_Kind => - Constraint_Error ("with a map", Pos); - return null; - - when Vec_Kind => - if Pos.Is_Empty then - raise Standard.Constraint_Error - with "cannot index with empty vector"; - elsif Pos.Length = 1 then - return Reference (This, Head (Pos)); - else - return Reference (Reference (This, Head (Pos)).all, - Tail (Pos)); - end if; - - when Scalar_Kinds => - -- We can already return a reference - return Ref_By_Scalar (This, Pos); - - end case; - end Reference; - - end References; - - --------------- - -- Iterators -- - --------------- - - package body Iterators is - - ------------------ - -- First_Cursor -- - ------------------ - - function First_Cursor (Container : Any) return Cursor is - begin - case Container.Kind is - when Map_Kind => - if Container.Impl.Map.Is_Empty then - return (Kind => Invalid); - else - return (Kind => Map_Cursor, - Map_Pos => Container.Impl.Map.First); - end if; - when Vec_Kind => - if Container.Impl.Vec.Is_Empty then - return (Kind => Invalid); - else - return (Kind => Vec_Cursor, - Vec_Pos => Container.Impl.Vec.First); - end if; - when others => - return (Kind => Invalid); - end case; - end First_Cursor; - - ----------------- - -- Next_Cursor -- - ----------------- - - function Next_Cursor (Container : Any; Pos : Cursor) return Cursor is - pragma Unreferenced (Container); - begin - case Pos.Kind is - when Map_Cursor => - declare - Next_Pos : Any_Maps.Cursor := Pos.Map_Pos; - begin - Any_Maps.Next (Next_Pos); - if Any_Maps.Has_Element (Next_Pos) then - return (Kind => Map_Cursor, Map_Pos => Next_Pos); - else - return (Kind => Invalid); - end if; - end; - when Vec_Cursor => - declare - Next_Pos : Any_Vecs.Cursor := Pos.Vec_Pos; - begin - Any_Vecs.Next (Next_Pos); - if Any_Vecs.Has_Element (Next_Pos) then - return (Kind => Vec_Cursor, Vec_Pos => Next_Pos); - else - return (Kind => Invalid); - end if; - end; - when Invalid => - return Pos; - end case; - end Next_Cursor; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Container : Any; Pos : Cursor) return Boolean is - pragma Unreferenced (Container); - begin - case Pos.Kind is - when Map_Cursor => - return Any_Maps.Has_Element (Pos.Map_Pos); - when Vec_Cursor => - return Any_Vecs.Has_Element (Pos.Vec_Pos); - when Invalid => - return False; - end case; - end Has_Element; - - ------------- - -- Element -- - ------------- - - function Element (Container : Any; Pos : Cursor) return Any is - pragma Unreferenced (Container); - begin - case Pos.Kind is - when Map_Cursor => - -- For maps, we return just the value part, discarding the key - return To_Any (Base_Any (Any_Maps.Element (Pos.Map_Pos))); - when Vec_Cursor => - return To_Any - (Base_Any (Any_Vecs.Element (Pos.Vec_Pos))); - when Invalid => - raise Constraint_Error with "Invalid cursor"; - end case; - end Element; - - end Iterators; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Pos : Cursor) return Boolean - is (Pos.Kind /= Invalid); - -end Yeison_Generic; diff --git a/yeison_12/src/yeison_generic.ads b/yeison_12/src/yeison_generic.ads deleted file mode 100644 index 4664cae..0000000 --- a/yeison_12/src/yeison_generic.ads +++ /dev/null @@ -1,405 +0,0 @@ -pragma Ada_2012; - -with Ada.Finalization; - -private with Ada.Containers.Indefinite_Ordered_Maps; -private with Ada.Containers.Indefinite_Vectors; -private with Ada.Strings.Wide_Wide_Unbounded; - -generic - -- Because big numbers aren't available in Ada 2012, and no other - -- convenient implementation is available that I know, we just delegate - -- this impl to clients. This limits us currently to Long_Long_Integer - -- as the max length of vectors. - type Int_Type is private; -- not range <> to allow Big_Integer - with function To_Integer (I : Int_Type) return Long_Long_Integer; - with function Image (I : Int_Type) return Wide_Wide_String is <>; - - type Real_Type is private; -- same about digits <> - with function Image (R : Real_Type) return Wide_Wide_String is <>; - - with function "<" (L, R : Int_Type) return Boolean is <>; - with function "<" (L, R : Real_Type) return Boolean is <>; -package Yeison_Generic with Preelaborate is - - subtype Universal_Integer is Long_Long_Integer; - - type Kinds is (Nil_Kind, - -- Uninitialized or explicitly null value - - Bool_Kind, - Int_Kind, - Real_Kind, - Str_Kind, - -- Scalar kinds; a single value - - Map_Kind, - Vec_Kind - -- Composite kinds; a collection of elements - ); - - subtype Scalar_Kinds - is Kinds range Kinds'Succ (Nil_Kind) .. Kinds'Pred (Map_Kind); - - subtype Composite_Kinds is Kinds range Map_Kind .. Kinds'Last; - - subtype Nonscalar_Kinds is Kinds with - Static_Predicate => Nonscalar_Kinds in Nil_Kind | Composite_Kinds; - - subtype Text is Wide_Wide_String; - - type Any is new Ada.Finalization.Controlled with private; - -- No other aspects here. This forces us to expose them in Yeison_12 and - -- Yeison_22, which involves some duplication, but otherwise there are - -- some ambiguities that rain on our parade... - - -- TODO: remove tagged once GNAT accepts dot notation for all private types - - function "=" (L, R : Any) return Boolean; - function "=" (L : Any; R : Text) return Boolean; - - function "<" (L, R : Any) return Boolean; - - function Precedes (L, R : Any) return Boolean renames "<"; - - -------------- - -- Common -- - -------------- - - type Image_Formats is (Ada_Like, JSON); - - type Image_Options is record - Compact : Boolean := False; - Ordered_Keys : Boolean := False; - end record; - - function Image (This : Any'Class; - Format : Image_Formats := Ada_Like; - Options : Image_Options := (others => <>)) - return Text; - - function Has_Value (This : Any) return Boolean with - Post => Has_Value'Result = (This.Kind /= Nil_Kind); - - function Kind (This : Any) return Kinds; - - type Any_Array is array (Positive range <>) of Any; - - ----------- - -- Nil -- - ----------- - - function Is_Nil (This : Any) return Boolean is (This.Kind = Nil_Kind); - - --------------- - -- Scalars -- - --------------- - - -- Separate type to ease initializations elsewhere - - type Scalar (<>) is tagged private; - - function Kind (This : Scalar) return Scalar_Kinds; - - function As_Boolean (This : Scalar) return Boolean; - function As_Integer (This : Scalar) return Int_Type; - function As_Real (This : Scalar) return Real_Type; - function As_Text (This : Scalar) return Text; - - -- See package Scalars below for initializations - - -- Retrieval - - function As_Scalar (This : Any'Class) return Scalar - with Pre => This.Kind in Scalar_Kinds; - - function As_Bool (This : Any) return Boolean - with Pre => This.Kind = Bool_Kind; - - function As_Int (This : Any) return Int_Type - with Pre => This.Kind = Int_Kind; - - function As_Real (This : Any) return Real_Type - with Pre => This.Kind = Real_Kind; - - function As_Text (This : Any) return Text - with Pre => This.Kind = Str_Kind; - - function As_UTF_8 (This : Any) return String - with Pre => This.Kind = Str_Kind; - - function As_Latin_1 (This : Any) return String - with Pre => This.Kind = Str_Kind; - - -- Overloaded renamings - function Get (This : Any'Class) return Scalar renames As_Scalar; - function Get (This : Any) return Boolean renames As_Bool; - function Get (This : Any) return Int_Type renames As_Int; - function Get (This : Any) return Real_Type renames As_Real; - function Get (This : Any) return Text renames As_Text; - - -- See package Make below for initializations - - ------------------- - -- Collections -- - ------------------- - - function Is_Empty (This : Any) return Boolean with - Pre => This.Is_Nil or else This.Kind in Composite_Kinds; - - function Length (This : Any) return Universal_Integer; - - ------------ - -- Maps -- - ------------ - - function Empty_Map return Any - with Post => Empty_Map'Result.Kind = Map_Kind; - - -- Note that JSON/TOML only accept string keys, but YAML accepts - -- Any(thing). Meanwhile, Ada 2022 doesn't let you use a non-static value - -- for keys/indices, so any non-basic type won't do here. Not sure if that - -- is worth reporting, as this is the subject of active discussion that no - -- overlapping values should be able to be given, and relaxations on this - -- point are expressly frowned upon. In conclusion: to initialize with - -- heterogeneous types, you can't use initialization expressions. - - procedure Insert (This : in out Any; - Key : Any; - Value : Any; - Replace : Boolean := False); - - function Map (This : Any) return Any is (This) with Inline; - -- A pass-through to help with disambiguation and estetics - - -- Old-style helpers - - function Insert (This : Any; - Key : Any; - Value : Any; - Replace : Boolean := False) - return Any; - -- Returns a copy with the new inserted value - - --------------- - -- Vectors -- - --------------- - - procedure Append (This : in out Any; Elem : Any) with - Pre => This.Kind = Vec_Kind; - - function Append (This : Any; Elem : Any) return Any with - Pre => This.Kind = Vec_Kind; - - function Empty_Vec return Any; - - function First_Index (This : Any) return Universal_Integer with - Pre => This.Kind = Vec_Kind; - - function Last_Index (This : Any) return Universal_Integer with - Pre => This.Kind = Vec_Kind; - - ------------- - -- Scalars -- - ------------- - - package Scalars is - - function New_Bool (Val : Boolean) return Scalar; - function New_Int (Val : Int_Type) return Scalar; - function New_Real (Val : Real_Type) return Scalar; - function New_Text (Val : Text) return Scalar; - - end Scalars; - - subtype Base_Any is Any; - - ---------------- - -- References -- - ---------------- - -- This unwanted complexity is caused by wanting to reuse logic in the - -- derived types for both the 2012 and 2022 versions. It really is not - -- worth the effort, lesson learned. - generic - type Any is new Yeison_Generic.Any with private; - with function To_Any (This : Yeison_Generic.Any) return Any is <>; - -- To avoid mistypes - package References is - - -- We don't want these to be primitive as that causes ambiguities in - -- the derived types usage. - - type Ref is access Any; - - function Reference (This : Any; Pos : Any) return Ref with - Pre => Pos.Kind in Scalar_Kinds | Vec_Kind; - -- Any may be a scalar, which will be used as key/index, or a vector - -- that will be consumed one element at a time. In YAML, keys can be - -- complex types, which is discouraged, and this is explicitly not - -- supported. - -- - -- If This is nil, the appropriate holder value will be created (vec - -- or map) depending on Any.Kind being Int or something else. If you - -- want to force either one, assign first an empty value. - - ---------------- - -- Indexing -- - ---------------- - - function Get (This : Any; Pos : Any) return Any with - Pre => This.Kind in Composite_Kinds - and then Pos.Kind in Scalar_Kinds | Vec_Kind; - -- Note this always returns a copy; for in place modification use Ref - - ------------ - -- Maps -- - ------------ - - function Has_Key (This : Any; Key : Any) return Boolean with - Pre => This.Kind = Map_Kind; - - function Keys (This : Any; Ordered : Boolean := False) return Any with - Pre => This.Kind = Map_Kind, - Post => Keys'Result.Kind = Vec_Kind; - - --------------- - -- Vectors -- - --------------- - - function Head (This : Any) return Any with - Pre => This.Kind = Vec_Kind and then not This.Is_Empty; - -- Taking the head of an empty vector is an error - - function Tail (This : Any) return Any with - Pre => This.Kind = Vec_Kind and then not This.Is_Empty, - Post => Tail'Result.Length = This.Length - 1; - -- Taking the tail of an empty vector is an error - - end References; - - ----------------- - -- Iterators -- - ----------------- - - type Cursor (<>) is private; - - function Has_Element (Pos : Cursor) return Boolean; - -- Cursor-only validity test, suitable as the formal of - -- Ada.Iterator_Interfaces. A cursor is valid iff it is not the special - -- "past the end" value produced by First_Cursor/Next_Cursor. - - generic - type Any is new Yeison_Generic.Any with private; - with function To_Any (This : Yeison_Generic.Any) return Any is <>; - package Iterators is - - function First_Cursor (Container : Any) return Cursor; - function Next_Cursor (Container : Any; Pos : Cursor) return Cursor; - function Has_Element (Container : Any; Pos : Cursor) return Boolean; - function Element (Container : Any; Pos : Cursor) return Any; - - end Iterators; - -private - - Unimplemented : exception; - - -- package Big_Ints renames Ada.Numerics.Big_Numbers.Big_Integers; - -- subtype Big_Int is Big_Ints.Big_Integer; - -- - -- package Big_Reals renames Ada.Numerics.Big_Numbers.Big_Reals; - -- subtype Big_Real is Big_Reals.Big_Real; - - package WWUStrings renames Ada.Strings.Wide_Wide_Unbounded; - subtype WWUString is WWUStrings.Unbounded_Wide_Wide_String; - - function U (S : Wide_Wide_String) return WWUString renames - Ada.Strings.Wide_Wide_Unbounded.To_Unbounded_Wide_Wide_String; - - function S (U : WWUString) return Text renames - Ada.Strings.Wide_Wide_Unbounded.To_Wide_Wide_String; - - type Any_Impl; - - type Any_Impl_Ptr is access Any_Impl; - -- Implementation is in body, so we can have a self-referential type but - -- also to control assignments via Controlled (when assigning through - -- indexing). - - function Nil_Impl return Any_Impl_Ptr; - - type Any is new Ada.Finalization.Controlled with record - Impl : Any_Impl_Ptr := Nil_Impl; - end record with - Type_Invariant => Impl /= null; - - overriding procedure Adjust (This : in out Any); - - overriding procedure Finalize (This : in out Any); - - type Vec is record - Vec : Any; - end record; - - -- These could go in the body if not because of - -- https://forum.ada-lang.io/t/bug-or-legit-instantiation-in-body-of- - -- preelaborable-generic-complains-about-non-static-constant/1742 - - package Any_Maps is - new Ada.Containers.Indefinite_Ordered_Maps (Any'Class, Any'Class, - "<" => Precedes); - - subtype Universal_Positive is - Universal_Integer range 1 .. Universal_Integer'Last; - - package Any_Vecs is - new Ada.Containers.Indefinite_Vectors (Universal_Positive, Any'Class); - - --------------- - -- Scalars -- - --------------- - - type Scalar_Data (Kind : Scalar_Kinds := Bool_Kind) is record - case Kind is - when Bool_Kind => - Bool : Boolean; - when Int_Kind => - Int : Int_Type; - when Real_Kind => - Real : Real_Type; - when Str_Kind => - Str : WWUString; - end case; - end record; - - type Scalar is tagged record - Data : Scalar_Data; - end record; - - -- For the benefit of the child Operators - - package Base is - -- Avoid primitiveness - - function New_Nil return Any; - function New_Bool (Val : Boolean) return Any; - function New_Int (Val : Int_Type) return Any; - function New_Real (Val : Real_Type) return Any; - function New_Text (Val : Text) return Any; - end Base; - - -- Cursor type for iteration - type Cursor_Kind is (Invalid, Map_Cursor, Vec_Cursor); - - type Cursor (Kind : Cursor_Kind := Invalid) is record - case Kind is - when Invalid => - null; - when Map_Cursor => - Map_Pos : Any_Maps.Cursor; - when Vec_Cursor => - Vec_Pos : Any_Vecs.Cursor; - end case; - end record; - -end Yeison_Generic; diff --git a/yeison_22/src/yeison.adb b/yeison_22/src/yeison.adb index 1c91f3e..4e4c0ec 100644 --- a/yeison_22/src/yeison.adb +++ b/yeison_22/src/yeison.adb @@ -4,10 +4,12 @@ with Ada.Characters.Conversions; with Ada.Characters.Wide_Wide_Latin_1; with Ada.Strings.Wide_Wide_Fixed; with Ada.Unchecked_Deallocation; +with GNAT.Compiler_Version; package body Yeison is package Fixed renames Ada.Strings.Wide_Wide_Fixed; + package Compiler_Version is new GNAT.Compiler_Version; use type Ada.Containers.Count_Type; use all type Ada.Strings.Trim_End; @@ -532,6 +534,22 @@ package body Yeison is new Ada.Unchecked_Deallocation (Any_Impl, Any_Impl_Ptr); begin Free (This.Impl); + exception + when others => + -- GNAT 12/13 has a finalization bug; suppress spurious exceptions + -- raised during deallocation when built with that compiler. This is + -- probably a bad idea, it would be better to avoid that compiler + -- entirely... + declare + V : constant String := Compiler_Version.Version; + begin + if V'Length < 2 or else + (V (V'First .. V'First + 1) /= "12" and then + V (V'First .. V'First + 1) /= "13") + then + raise; + end if; + end; end Finalize; ------------ diff --git a/yeison_22/src/yeison.ads b/yeison_22/src/yeison.ads index d063ac5..7d7cfd0 100644 --- a/yeison_22/src/yeison.ads +++ b/yeison_22/src/yeison.ads @@ -94,10 +94,13 @@ package Yeison with Preelaborate is subtype Int is Any with Dynamic_Predicate => Int.Kind = Int_Kind; subtype Real is Any with Dynamic_Predicate => Real.Kind = Real_Kind; subtype Str is Any with Dynamic_Predicate => Str.Kind = Str_Kind; - subtype Map is Any with - Dynamic_Predicate => Map.Kind in Nil_Kind | Map_Kind; - subtype Vec is Any with - Dynamic_Predicate => Vec.Kind in Nil_Kind | Vec_Kind; + subtype Vec is Any with Dynamic_Predicate => Vec.Kind = Vec_Kind; + -- Map cannot carry a Dynamic_Predicate: it is the container-Aggregate + -- target, and GNAT default-initializes the aggregate's temporary as Map + -- (Nil, before Empty/Add_Named run) and checks the predicate on it, which + -- either fails (strict) or crashes finalization (Nil-tolerant). So Map is a + -- plain documentation subtype; its Map_Kind is guaranteed by construction. + subtype Map is Any; type Any_Array is array (Positive range <>) of Any; diff --git a/yeison_22/test/.gitignore b/yeison_22/test/.gitignore deleted file mode 100644 index 5866d7b..0000000 --- a/yeison_22/test/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -/obj/ -/bin/ -/alire/ -/config/ diff --git a/yeison_22/test/alire.toml b/yeison_22/test/alire.toml deleted file mode 100644 index 912b610..0000000 --- a/yeison_22/test/alire.toml +++ /dev/null @@ -1,24 +0,0 @@ -name = "test" -description = "Test the library through examples" -version = "0.1.0-dev" - -authors = ["Alejandro R. Mosteo"] -maintainers = ["Alejandro R. Mosteo "] -maintainers-logins = ["mosteo"] -licenses = "MIT OR Apache-2.0 WITH LLVM-exception" -website = "" -tags = [] - -executables = ["test"] - -[build-profiles] -"*" = "validation" - -[build-switches] -"*".ada_version = "Ada2022" - -[[depends-on]] -yeison = "*" - -[[pins]] -yeison = { path='..' } diff --git a/yeison_22/test/src/test.adb b/yeison_22/test/src/test.adb deleted file mode 100644 index 3f9b794..0000000 --- a/yeison_22/test/src/test.adb +++ /dev/null @@ -1,128 +0,0 @@ -pragma Ada_2022; - -with Ada.Strings.UTF_Encoding.Wide_Wide_Strings; -use Ada.Strings.UTF_Encoding.Wide_Wide_Strings; - -with GNAT.IO; use GNAT.IO; - -with Yeison.Operators; use Yeison; use Yeison.Operators; - --- with Test_Crate; pragma Unreferenced (Test_Crate); -with Test_Indexing; - -procedure Test is - - ------------ - -- Report -- - ------------ - - procedure Report (Label : String; Value : Yeison.Any) is - begin - Put_Line (Label & " (" & Value.Kind'Image & "):"); - Put_Line (Encode (Value.Image)); - New_Line; - end Report; - - --------------- - -- Report_RW -- - --------------- - - procedure Report_RW (Label : String; Value : in out Yeison.Any) is - begin - Report (Label, Value); - end Report_RW; - -begin - Report ("empty", Make.Nil); - - -- Bool scalars - - Report ("literal bool", True); - - -- Int scalars - - Report ("literal integer", 1); - - -- String scalars - - Report ("literal string", "asdf"); - - declare - S : constant Any := "qwerS"; - begin - Report ("var string", S); - end; - - -- Maps - - Report ("empty map", []); - Report ("simple map", ["one" => 1]); - Report ("literal map", - ["one" => "one", - "two" => 2, - "three" => +[1, "two", 3], - "four" => ["4a" => 4]]); - - declare - M : Any; - begin - M ("hi") := "there"; - Report ("map incremental", M); - end; - - -- Vectors - - Report ("empty vec", []); - Report ("homo vec", +[1, 2, 3]); - Report ("hetero vec", +[1, "two", 3]); - - declare - V : Any; - begin - V (1) := "one"; - Report ("initialized vec", V); - V (2) := "two"; - V (1) := 1; - Report ("modified vec", V); - end; - - -- References - - declare - X : Any; - begin - X.As_Ref := 1; - Report ("X = 1", X); - X.As_Ref := "one"; - Report ("X = ""one""", X); - X.As_Ref := Any'[]; - Report ("X = {}", X); - Report ("bug?", Map'[]); - X.As_Ref := Map'[]; - Report ("X = {}", X); - X.As_Ref := Empty_Vec; -- Vec'[] results in an invalid value because ??? - Report ("X = []", X); - end; - - Report ("constant indexing", - Any'["key" => "val"] ("key")); - declare - pragma Warnings (Off); -- Spurious could be constant (?) - M : Any := Empty_Map.Insert ("key", "val"); - pragma Warnings (On); - begin - Report_RW ("variable indexing", M ("key")); - end; - - declare - M : constant Any := ["key" => "val"]; - begin - Report ("map on the fly", M); - Report ("map indexing", M ("key")); - pragma Assert (M ("key").As_Text = "val"); - end; - - pragma Assert - (Any'["key" => "val"] ("key").As_Text = "val"); - -end Test; diff --git a/yeison_22/test/src/test_crate.adb b/yeison_22/test/src/test_crate.adb deleted file mode 100644 index 3b56136..0000000 --- a/yeison_22/test/src/test_crate.adb +++ /dev/null @@ -1,8 +0,0 @@ -with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO; - -package body Test_Crate is -begin - Put_Line ("Crate: " & Crate.Image); - Put_Line ("Map nested indexing: Crate (""depends-on"") (""aaa"") => " - & Crate ("depends-on") ("aaa").Image); -end Test_Crate; diff --git a/yeison_22/test/src/test_crate.ads b/yeison_22/test/src/test_crate.ads deleted file mode 100644 index 4402a9a..0000000 --- a/yeison_22/test/src/test_crate.ads +++ /dev/null @@ -1,36 +0,0 @@ -with Yeison.Operators; use Yeison; use Yeison.Operators; - -package Test_Crate with Elaborate_Body is - - subtype Text is Wide_Wide_String; - - URL : constant Text := "url"; - Commit : constant Text := "commit"; - - Linux : constant Text := "linux"; - Other : constant Text := "..."; - - Crate : constant Yeison.Map - := [ - "name" => "alr", - "description" => "The Alire project command-line tool", - "version" => "1.2.0-dev", - "auto-gpr-with" => False, - "maintainers" => +["mosteo", "chouteau"], - - "depends-on" => - ["aaa" => "~0.2.3", - "ada_toml" => "~0.1", - "spdx" => "~0.2"], - - "pins" => - Map'["ada_toml" => [URL => "http://adatoml", Commit => "abcd"], - "spdx" => [URL => "http://spdx", Commit => "1234"]], - - "available" => - Map'["case(os)" => - Map'[Linux => True, - Other => False]] - ]; - -end Test_Crate; diff --git a/yeison_22/test/src/test_indexing.adb b/yeison_22/test/src/test_indexing.adb deleted file mode 100644 index 942e2ed..0000000 --- a/yeison_22/test/src/test_indexing.adb +++ /dev/null @@ -1,111 +0,0 @@ -with Yeison.Operators; use Yeison.Operators; - -with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO; - -package body Test_Indexing is - - pragma Style_Checks ("-gnatM120"); - - A1 : constant Yeison.Int := 1; - -- An integer atom; - - A2 : constant Yeison.Str := "string"; - -- A string atom - - A3 : constant Yeison.Bool := Yeison.True; - -- A Boolean atom - - A4 : constant Yeison.Real := 3.14; - -- A real atom - - M1 : constant Yeison.Map := ["one" => A1, "two" => A2] with Unreferenced; - -- A map initialized with yeison atoms - - M2 : constant Yeison.Map := ["one" => 1, "two" => "two"]; - -- A map initialized with literals - - M3 : constant Yeison.Map := ["one" => A1, "two" => "two", "three" => M2]; - -- A map containing other maps - - V1 : constant Yeison.Vec := +[A1, A2, A3] with Unreferenced; - -- A vector initialized with atoms - - V2 : constant Yeison.Vec := +[1, 2, 3] with Unreferenced; - -- A vector initialized with integer literals - - V3 : constant Yeison.Vec := +["one", "two", "three"] with Unreferenced; - -- A vector initialized with string literals - - V4 : constant Yeison.Vec := +["one", 2, "three", 4.0]; - -- A vector made of mixed atoms/literals - - M4 : constant Yeison.Map := ["one" => A1, - "two" => 2, - "three" => M3, - "four" => V4]; - -- A map initialized with all kinds of elements - - V5 : constant Yeison.Vec := +[A1, 2, M3, V4, "five"]; - -- A vector initialized with all kinds of elements - - M5 : constant Yeison.Map := ["one" => 1, - "two" => ["two" => 2, - "three" => M3], - "zri" => +[1, 2, 3]]; - -- Inline declaration of nested maps/vectors. "+" needed until - - M6 : constant Yeison.Map := ["one" => 1, - "two" => ["two" => 2, - "three" => M3], - "zri" => +[1, M2, 3]]; - -- Inline declaration of nested maps/vectors - - V6 : constant Yeison.Vec := +[1, - +[1, 2], - ["one" => 1, - "two" => M2]]; - -- A vector with a nested vector/map. Same problem as with maps. - - X0 : Yeison.Any; - - X1 : constant Yeison.Any := 1; - X2 : constant Yeison.Any := "two"; - X3 : constant Yeison.Any := M4; - X4 : constant Yeison.Any := V5; - -- Storing any kind of value in a variable - -begin - Put_Line ("X0: " & X0.Image); - X0 := "changed"; - Put_Line ("X0: " & X0.Image); - X0 := 1; - Put_Line ("X0: " & X0.Image); - - Put_Line ("X1: " & X1.Image); - Put_Line ("X2: " & X2.Image); - Put_Line ("X3: " & X3.Image); - Put_Line ("X4: " & X4.Image); - - Put_Line ("M5: " & M5.Image); - Put_Line ("V6: " & V6.Image); - - Put_Line ("Map indexing: M4 (""one"") => " & M4 ("one").Image); - - Put_Line ("Map nested indexing alt syntax: " - & M5 ("two") ("two").Image); - - Put_Line ("Map nested indexing alt alt syntax: " & M5 ("two" / "two").Image); - - Put_Line ("Nested mixed indexing alt: " & M6 ("zri") (2) ("one").Image); - Put_Line ("Map nested indexing w vec: " & M6 (+["zri", 2]).Image); - Put_Line ("Nested mixed indexing alt: " & M6 ("zri" / 2 / "one").Image); - - Put_Line ("Vec indexing: V6 (1) = " & V6 (1).Image); - Put_Line ("Vec nested indexing V6 (2) (2) = " - & V6 (2) (2).Image); - Put_Line ("Vec nested indexing alt syntax V6 ((2, 2)) = " & V6 (2) (2).Image); - Put_Line ("Vec mixed indexing: " & V6.Get (3 / "one").Image); - - Put_Line ("Real image: " & A4.Image); - -end Test_Indexing; diff --git a/yeison_22/test/src/test_indexing.ads b/yeison_22/test/src/test_indexing.ads deleted file mode 100644 index ed36bf7..0000000 --- a/yeison_22/test/src/test_indexing.ads +++ /dev/null @@ -1,3 +0,0 @@ -package Test_Indexing with Elaborate_Body is - -end Test_Indexing; diff --git a/yeison_22/test/test.gpr b/yeison_22/test/test.gpr deleted file mode 100644 index 18bb217..0000000 --- a/yeison_22/test/test.gpr +++ /dev/null @@ -1,23 +0,0 @@ -with "config/test_config.gpr"; - -project Test is - - for Source_Dirs use ("src/", "config/"); - for Object_Dir use "obj/" & Test_Config.Build_Profile; - for Create_Missing_Dirs use "True"; - for Exec_Dir use "bin"; - for Main use ("test.adb"); - - package Compiler is - for Default_Switches ("Ada") use Test_Config.Ada_Compiler_Switches; - end Compiler; - - package Binder is - for Switches ("Ada") use ("-Es"); -- Symbolic traceback - end Binder; - - package Install is - for Artifacts (".") use ("share"); - end Install; - -end Test; diff --git a/yeison_22/tests/src/yeison_tests-image_formats.adb b/yeison_22/tests/src/yeison_tests-image_formats.adb index f64d0e6..de4d3fe 100644 --- a/yeison_22/tests/src/yeison_tests-image_formats.adb +++ b/yeison_22/tests/src/yeison_tests-image_formats.adb @@ -21,7 +21,7 @@ begin Assert (+Empty_Vec.Image (JSON) = "[]", "empty vec json"); -- Compact one-element rendering - Assert (+M.Image (JSON, (Compact => True, others => <>)) = "{ ""one"": 1 }", + Assert (+M.Image (JSON, (Compact => True, others => <>)) = "{ ""one"": 1 }", "compact json map"); Assert (+V.Image (JSON, (Compact => True, others => <>)) = "[ 1 ]", "compact json vec"); diff --git a/yeison_dev.gpr b/yeison_dev.gpr index 49cdd21..d072829 100644 --- a/yeison_dev.gpr +++ b/yeison_dev.gpr @@ -5,7 +5,7 @@ aggregate project Yeison_Dev is for Project_Path use ("yeison_12", "yeison_22"); - for Project_Files use ("yeison_12/test/test_12.gpr", - "yeison_22/test/test.gpr"); + for Project_Files use ("yeison_12/tests/yeison_12_tests.gpr", + "yeison_22/tests/yeison_tests.gpr"); end Yeison_Dev; From 9c32c43cc3651dfa55739174c6725cf28296688f Mon Sep 17 00:00:00 2001 From: "Alejandro R. Mosteo" Date: Sun, 31 May 2026 19:55:47 +0200 Subject: [PATCH 3/4] Future note for GNAT 16 --- .github/workflows/build.yml | 5 +++++ yeison_22/src/yeison-operators.ads | 7 +++++++ 2 files changed, 12 insertions(+) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 8dc1b55..d0479b3 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -17,6 +17,11 @@ jobs: gnat_version: [12, 13, 14, 15] # Pre -12 don't support Ada 2022 # 13.2 is buggy w.r.t. to finalization + # When 16 is added here: re-test combined named+unnamed container + # aggregates (single type with both Add_Unnamed and Add_Named). Rejected + # by 14.2/15.2 ("conflicting operations for aggregate, RM 4.3.5"); if 16 + # supports it, drop yeison_22's "+[...]" operator. See + # yeison_22/src/yeison-operators.ads. exclude: # Some combos are not supported due to missing pieces in the toolchain # No builds of gcc-10, -11, -12 that work on arm64 diff --git a/yeison_22/src/yeison-operators.ads b/yeison_22/src/yeison-operators.ads index 95eccf9..71dd41d 100644 --- a/yeison_22/src/yeison-operators.ads +++ b/yeison_22/src/yeison-operators.ads @@ -5,6 +5,13 @@ package Yeison.Operators with Preelaborate is -- The literal and aggregate aspects cover scalars and maps; these two -- operators cover vectors (+[...]) and path-style building (a / b). + -- FUTURE (re-test when GNAT 16 is added): a single type defining BOTH + -- Add_Unnamed and Add_Named in its Aggregate aspect (so [1, 2, 3] builds a + -- vector and ["k" => v] a map) is still rejected by GNAT 14.2 and 15.2 + -- ("conflicting operations for aggregate (RM 4.3.5)"), even with -gnatX. + -- Once GNAT implements that amendment, give Yeison.Any an + -- Add_Unnamed => Append and drop this "+" operator: +[...] becomes [...]. + function "+" (This : Any_Array) return Any with Post => "+"'Result.Kind = Vec_Kind; -- Build a vector from an array aggregate: +[1, "two", 3]. From 04e3d1f5d93a766763ede7b7e736cd937a1b3ffb Mon Sep 17 00:00:00 2001 From: "Alejandro R. Mosteo" Date: Sun, 31 May 2026 20:01:31 +0200 Subject: [PATCH 4/4] Remove GNAT 12 from testing (too old) --- .github/workflows/build.yml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index d0479b3..b407292 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -14,9 +14,10 @@ jobs: fail-fast: false matrix: os: [macos-latest, windows-latest, ubuntu-latest] - gnat_version: [12, 13, 14, 15] - # Pre -12 don't support Ada 2022 - # 13.2 is buggy w.r.t. to finalization + gnat_version: [13, 14, 15] + # Pre -12 don't support Ada 2022. + # 12 dies with bug box in some Yeison 22 tests. + # 13.x is buggy w.r.t. to finalization. # When 16 is added here: re-test combined named+unnamed container # aggregates (single type with both Add_Unnamed and Add_Named). Rejected # by 14.2/15.2 ("conflicting operations for aggregate, RM 4.3.5"); if 16