Changeset 2634

Timestamp:

02/25/08 17:55:16 (11 months ago)

Author:

ogorod

Message:

implemented Elaboration_Order

Files:

• trunk/tendra/src/producers/ada/asis/asis-compilation_units-relations.adb (modified) (18 diffs)

trunk/tendra/src/producers/ada/asis/asis-compilation_units-relations.adb

@@ -47 +47 @@
-         return Boolean;
-
+      function Append
+        (List : in Compilation_Unit_List_Access;
+         Unit : in Compilation_Unit)
+         return Compilation_Unit_List_Access;
+
+      function Append
+        (List  : in Compilation_Unit_List_Access;
+         Units : in Compilation_Unit_List)
+         return Compilation_Unit_List_Access;
+
+      procedure Remove_From_List
+        (List : in out Compilation_Unit_List_Access;
+         Unit : in     Compilation_Unit);
+
-      procedure Remove_From_List
-        (List : in out Compilation_Unit_List;
-         From : in     List_Index;
-         Unit : in     Compilation_Unit);
-
-      function Append
-        (List : in Compilation_Unit_List_Access;
-         Unit : in Compilation_Unit)
-         return Compilation_Unit_List_Access;
-
-      function Append
-        (List  : in Compilation_Unit_List_Access;
-         Units : in Compilation_Unit_List)
-         return Compilation_Unit_List_Access;
-
-      -- Tree --
@@ -238 +242 @@
-         Body_Elaborated : Boolean := False;
-
-
+
+
+
-      end record;
-
@@ -247 +253 @@
-        (This : in Tree_Node_Access)
-         return Boolean;
+
+      function Is_Preelaborate
+        (This : in Tree_Node_Access)
+         return Boolean;
+
+      function Is_Elaborate_Body
+        (This : in Tree_Node_Access)
+         return Boolean;
+
+      procedure Retrive_Pragmas
+        (This : in Tree_Node_Access);
-
-      -- Root_Tree --
@@ -467 +484 @@
-
-   -------------------------
- *
+
-   -------------------------
-
@@ -2516 +2533 @@
-         Unit : in Compilation_Unit)
-      is
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-      end Append;
-
@@ -2576 +2605 @@
-            if Prev_Node = To_Node then
-               if Circular /= null then
+
-                  for Index in reverse Circular.all'Range loop
-                     Node.Circular := Append (Node.Circular, Circular (Index));
@@ -2581 +2611 @@
-
-                  Node.Circular := Append (Node.Circular, Node.Unit);
+                  Node.Circular := Append (Node.Circular, Circular (Circular.all'Last));
-
-                  Deallocate (Circular);
@@ -2586 +2617 @@
-                  --  2 pair (self and parent)
-                  Node.Circular := Append
-
+, Prev_Node.Unit
-               end if;
-
@@ -3172 +3203 @@
-               Node.Circular_Added := True;
-
-
+
+
+
-                  Circular_List := Append
-
-
-
-
-
-
-
-
-
+
+
+
-               end loop;
-            end if;
@@ -3358 +3385 @@
-      -----------------------------
-
---      An_Elaborate_Pragma,              --  10.2.1(20)
---      An_Elaborate_All_Pragma,          --  10.2.1(21)
---      An_Elaborate_Body_Pragma,         --  10.2.1(22)
---      A_Partition_Elaboration_Policy_Pragma,   --  H.6 (3)
---      A_Preelaborable_Initialization_Pragma,   --  7.6 (5)
---      A_Preelaborate_Pragma,            --  10.2.1(3)
---      A_Pure_Pragma,                    --  10.2.1(14)
-
-      function Create_Elaboration_Tree
@@ -3371 +3393 @@
-         return Root_Tree_Access
-      is
-
+
+
+
+
-            (Node : in Tree_Node_Access);
+
+         procedure Process_Preelaborate_Spec
+           (Node : in Tree_Node_Access);
+
+         procedure Process_Preelaborate_Body
+           (Node : in Tree_Node_Access);
+
+         procedure Process_Spec
+           (Node : in Tree_Node_Access);
+
+         procedure Process_Body
+            (Node : in Tree_Node_Access);
+
+         procedure Elab_Spec
+           (Node : in Tree_Node_Access);
+
+         procedure Elab_Body
+           (Node      : in Tree_Node_Access;
+            All_Bodys : in Boolean := False);
+
+         procedure Elab_Subunits
+           (Node : in Tree_Node_Access);
+
+         procedure Elab_Pragmed_Bodys
+           (Node : in Tree_Node_Access;
+            Unit : in Compilation_Unit);
-
-         Result : Root_Tree_Access := new Root_Tree;
@@ -3381 +3432 @@
-            Library_Unit_Declaration ("Standard", The_Context);
-
-
-
+
+
+
+
-            (Node : in Tree_Node_Access)
-         is
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-         begin
-            if not Node.Elaborated
@@ -3391 +3613 @@
-            then
-               if Is_Pure (Node) then
-
-
+
-               end if;
-            end if;
@@ -3398 +3619 @@
-            if Node.Prevs /= null then
-               for Index in Node.Prevs.all'Range loop
-
+_Spec
-               end loop;
-            end if;
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-      begin
@@ -3409 +3717 @@
-         Append (Result, Std);
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-         return Result;
@@ -3432 +3768 @@
-      begin
-         if This.Internal_Pure = Unknown then
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
-         end if;
-
@@ -3461 +3777 @@
-         end if;
-      end Is_Pure;
+
+      ---------------------
+      -- Is_Preelaborate --
+      ---------------------
+
+      function Is_Preelaborate
+        (This : in Tree_Node_Access)
+         return Boolean
+      is
+      begin
+         if This.Internal_Preelaborate = Unknown then
+            Retrive_Pragmas (This);
+         end if;
+
+         if This.Internal_Preelaborate = Extended_True then
+            return True;
+         else
+            return False;
+         end if;
+      end Is_Preelaborate;
+
+      -----------------------
+      -- Is_Elaborate_Body --
+      -----------------------
+
+      function Is_Elaborate_Body
+        (This : in Tree_Node_Access)
+         return Boolean
+      is
+      begin
+         if This.Internal_Spec_With_Body = Unknown then
+            Retrive_Pragmas (This);
+         end if;
+
+         if This.Internal_Spec_With_Body = Extended_True then
+            return True;
+         else
+            return False;
+         end if;
+      end Is_Elaborate_Body;
+
+      ---------------------
+      -- Retrive_Pragmas --
+      ---------------------
+
+      procedure Retrive_Pragmas
+        (This : in Tree_Node_Access)
+      is
+      begin
+         if Is_Nil (This.Unit) then
+            return;
+         end if;
+
+         declare
+            Pragma_List : constant Asis.Pragma_Element_List :=
+               Asis.Elements.Corresponding_Pragmas
+                  (Asis.Elements.Unit_Declaration (This.Unit));
+         begin
+            for Index in Pragma_List'Range loop
+               if Pragma_Kind (Pragma_List (Index).all) = A_Pure_Pragma then
+                  This.Internal_Pure := Extended_True;
+               end if;
+
+               if Pragma_Kind (Pragma_List (Index).all) =
+                 A_Preelaborate_Pragma
+               then
+                  This.Internal_Preelaborate := Extended_True;
+               end if;
+
+               if Pragma_Kind (Pragma_List (Index).all) =
+                 An_Elaborate_Body_Pragma
+               then
+                  This.Internal_Spec_With_Body := Extended_True;
+               end if;
+
+            end loop;
+         end;
+
+         if This.Internal_Pure = Unknown then
+            This.Internal_Pure := Extended_False;
+         end if;
+
+         if This.Internal_Preelaborate = Extended_True then
+            This.Internal_Preelaborate := Extended_False;
+         end if;
+
+         if This.Internal_Spec_With_Body = Unknown then
+            This.Internal_Spec_With_Body := Extended_False;
+         end if;
+      end Retrive_Pragmas;
-
-      ------------------
@@ -3842 +4248 @@
-      ----------------------
-
+      procedure Remove_From_List
+        (List : in out Compilation_Unit_List_Access;
+         Unit : in     Compilation_Unit)
+      is
+      begin
+         if List = null then
+            return;
+         end if;
+
+         for Index in List'Range loop
+            if Is_Identical (List (Index), Unit) then
+               if List'Length = 1 then
+                  Deallocate (List);
+               else
+                  declare
+                     Internal : constant Compilation_Unit_List_Access :=
+                        new Compilation_Unit_List (1 .. List'Length - 1);
+                  begin
+                     Internal (1 .. Index - 1) := List (1 .. Index - 1);
+                     Internal (Index .. Internal'Last) := List (Index + 1 .. List'Last);
+                     Deallocate (List);
+                     List := Internal;
+                  end;
+               end if;
+
+               exit;
+            end if;
+         end loop;
+      end Remove_From_List;
+
+      -- Remove_From_List --
-      procedure Remove_From_List
-        (List : in out Compilation_Unit_List;