diff options
| -rw-r--r-- | src/kompsos-collector.adb | 21 | ||||
| -rw-r--r-- | src/kompsos-collector.ads | 4 | ||||
| -rw-r--r-- | src/kompsos-pretty_print.adb | 98 | ||||
| -rw-r--r-- | src/kompsos-pretty_print.ads | 23 | ||||
| -rw-r--r-- | src/kompsos.adb | 18 | ||||
| -rw-r--r-- | src/kompsos.ads | 4 |
6 files changed, 134 insertions, 34 deletions
diff --git a/src/kompsos-collector.adb b/src/kompsos-collector.adb index 16e2b1f..c95453e 100644 --- a/src/kompsos-collector.adb +++ b/src/kompsos-collector.adb @@ -7,9 +7,7 @@ with - Ada.Unchecked_Deallocation, - System.Address_To_Access_Conversions, - System.Storage_Elements; + Ada.Unchecked_Deallocation; package body Kompsos.Collector is @@ -56,23 +54,6 @@ package body Kompsos.Collector is -- Internal Helpers -- ------------------------ - -- Map Keys -- - - package World_Convert is new System.Address_To_Access_Conversions (World_Component); - - function "<" - (Left, Right : in World_Component_Access) - return Boolean - is - use System.Storage_Elements; - begin - return - To_Integer (World_Convert.To_Address (World_Convert.Object_Pointer (Left))) < - To_Integer (World_Convert.To_Address (World_Convert.Object_Pointer (Right))); - end "<"; - - - -- Unification -- function Fully_Contains diff --git a/src/kompsos-collector.ads b/src/kompsos-collector.ads index 4bca3b4..8743ecc 100644 --- a/src/kompsos-collector.ads +++ b/src/kompsos-collector.ads @@ -41,10 +41,6 @@ private type Constant_World_Access is access constant World; - function "<" - (Left, Right : in World_Component_Access) - return Boolean; - type Eval_Kind is (Unify_Data, Disjunct_Data, diff --git a/src/kompsos-pretty_print.adb b/src/kompsos-pretty_print.adb index 834c0ca..8d11f81 100644 --- a/src/kompsos-pretty_print.adb +++ b/src/kompsos-pretty_print.adb @@ -87,8 +87,6 @@ package body Kompsos.Pretty_Print is end Image; - - function Image (Item : in State) return String @@ -151,8 +149,6 @@ package body Kompsos.Pretty_Print is end Image; - - function Image (Item : in World) return String @@ -175,6 +171,100 @@ package body Kompsos.Pretty_Print is end Image; + + + procedure Do_Structure_DOT + (This : in World; + Nodes : in out DOT_Node_Maps.Map; + Next : in out Long_Natural; + Result : in out SU.Unbounded_String) is + begin + if This.Actual = null or else Nodes.Contains (This.Actual) then + return; + end if; + Nodes.Insert (This.Actual, Next); + Next := Next + 1; + case This.Actual.Kind is + when Static_Node => + SU.Append (Result, Latin.HT & + "n" & Image (Nodes.Element (This.Actual)) & " [label=""static""];" & Latin.LF); + when Fresh_Node => + SU.Append (Result, Latin.HT & + "n" & Image (Nodes.Element (This.Actual)) & " [label=""fresh""];" & Latin.LF); + Do_Structure_DOT (This.Actual.Frs_World, Nodes, Next, Result); + if Nodes.Contains (This.Actual.Frs_World.Actual) then + SU.Append (Result, Latin.HT & + "n" & Image (Nodes.Element (This.Actual)) & " -> " & + "n" & Image (Nodes.Element (This.Actual.Frs_World.Actual)) & ";" & Latin.LF); + end if; + when Unify_Node => + SU.Append (Result, Latin.HT & + "n" & Image (Nodes.Element (This.Actual)) & " [label=""unify""];" & Latin.LF); + Do_Structure_DOT (This.Actual.Uni_World, Nodes, Next, Result); + if Nodes.Contains (This.Actual.Uni_World.Actual) then + SU.Append (Result, Latin.HT & + "n" & Image (Nodes.Element (This.Actual)) & " -> " & + "n" & Image (Nodes.Element (This.Actual.Uni_World.Actual)) & ";" & Latin.LF); + end if; + when Disjunct_Node => + SU.Append (Result, Latin.HT & + "n" & Image (Nodes.Element (This.Actual)) & " [label=""disjunct""];" & Latin.LF); + Do_Structure_DOT (This.Actual.Dis_World1, Nodes, Next, Result); + Do_Structure_DOT (This.Actual.Dis_World2, Nodes, Next, Result); + if Nodes.Contains (This.Actual.Dis_World1.Actual) then + SU.Append (Result, Latin.HT & + "n" & Image (Nodes.Element (This.Actual)) & " -> " & + "n" & Image (Nodes.Element (This.Actual.Dis_World1.Actual)) & + " [label=""1""];" & Latin.LF); + end if; + if Nodes.Contains (This.Actual.Dis_World2.Actual) then + SU.Append (Result, Latin.HT & + "n" & Image (Nodes.Element (This.Actual)) & " -> " & + "n" & Image (Nodes.Element (This.Actual.Dis_World2.Actual)) & + " [label=""2""];" & Latin.LF); + end if; + when Conjunct_Node => + SU.Append (Result, Latin.HT & + "n" & Image (Nodes.Element (This.Actual)) & " [label=""conjunct""];" & Latin.LF); + Do_Structure_DOT (This.Actual.Con_World, Nodes, Next, Result); + if Nodes.Contains (This.Actual.Con_World.Actual) then + SU.Append (Result, Latin.HT & + "n" & Image (Nodes.Element (This.Actual)) & " -> " & + "n" & Image (Nodes.Element (This.Actual.Con_World.Actual)) & ";" & Latin.LF); + end if; + when Recurse_Node => + SU.Append (Result, Latin.HT & + "n" & Image (Nodes.Element (This.Actual)) & " [label=""recurse""];" & Latin.LF); + Do_Structure_DOT (This.Actual.Rec_World, Nodes, Next, Result); + if Nodes.Contains (This.Actual.Rec_World.Actual) then + SU.Append (Result, Latin.HT & + "n" & Image (Nodes.Element (This.Actual)) & " -> " & + "n" & Image (Nodes.Element (This.Actual.Rec_World.Actual)) & ";" & Latin.LF); + end if; + end case; + end Do_Structure_DOT; + + + function Structure_DOT + (This : in World; + Name : in String := "") + return String + is + Result : SU.Unbounded_String; + Nodes : DOT_Node_Maps.Map; + Next_ID : Long_Natural := 0; + begin + SU.Append (Result, "digraph "); + if Name /= "" then + SU.Append (Result, Name & " "); + end if; + SU.Append (Result, "{" & Latin.LF); + Do_Structure_DOT (This, Nodes, Next_ID, Result); + SU.Append (Result, "}"); + return SU.To_String (Result); + end Structure_DOT; + + end Kompsos.Pretty_Print; diff --git a/src/kompsos-pretty_print.ads b/src/kompsos-pretty_print.ads index 1316d5a..19da0af 100644 --- a/src/kompsos-pretty_print.ads +++ b/src/kompsos-pretty_print.ads @@ -6,6 +6,11 @@ -- See license.txt for further details +private with + + Ada.Containers.Ordered_Maps; + + generic with function Element_Image (Item : in Element_Type) @@ -17,27 +22,31 @@ package Kompsos.Pretty_Print is (Item : in Integer) return String; - function Image (Item : in Term) return String; - function Image (Item : in State) return String; - function Image (Item : in State_Array) return String; - function Image (Item : in World) return String; + + + function Structure_DOT + (This : in World; + Name : in String := "") + return String; + + private @@ -45,12 +54,16 @@ private (Item : in Long_Natural) return String; - function Image (Item : in Variable) return String; + package DOT_Node_Maps is new Ada.Containers.Ordered_Maps + (Key_Type => World_Component_Access, + Element_Type => Long_Natural); + + end Kompsos.Pretty_Print; diff --git a/src/kompsos.adb b/src/kompsos.adb index e525f23..1fedb86 100644 --- a/src/kompsos.adb +++ b/src/kompsos.adb @@ -9,7 +9,9 @@ with Ada.Unchecked_Deallocation, - Kompsos.Collector; + Kompsos.Collector, + System.Address_To_Access_Conversions, + System.Storage_Elements; package body Kompsos is @@ -191,6 +193,20 @@ package body Kompsos is -- Worlds -- + package World_Convert is new System.Address_To_Access_Conversions (World_Component); + + function "<" + (Left, Right : in World_Component_Access) + return Boolean + is + use System.Storage_Elements; + begin + return + To_Integer (World_Convert.To_Address (World_Convert.Object_Pointer (Left))) < + To_Integer (World_Convert.To_Address (World_Convert.Object_Pointer (Right))); + end "<"; + + function Static (Item : in State) return World'Class diff --git a/src/kompsos.ads b/src/kompsos.ads index e9bbefd..15f61bb 100644 --- a/src/kompsos.ads +++ b/src/kompsos.ads @@ -559,6 +559,10 @@ private type World_Component_Access is access World_Component; + function "<" + (Left, Right : in World_Component_Access) + return Boolean; + type Lazy_Kind is (Zero_Arg, One_Arg, Many_Arg); type Lazy_Data (Kind : Lazy_Kind) is record |