dependency_graph_extractor_22.0.0_992fc1c4/src/extraction.adb

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
with Ada.Exceptions;
with Ada.Strings.Equal_Case_Insensitive;
with Ada.Text_IO;
with Extraction.Bodies_For_Decls;
with Extraction.Bodies_For_Entries;
with Extraction.Decls;
with Extraction.Deferred_Constants;
with Extraction.Derived_Type_Defs;
with Extraction.Direct_Calls;
with Extraction.File_System;
with Extraction.Generic_Instantiations;
with Extraction.Graph_Operations;
with Extraction.Node_Edge_Types;
with Extraction.Primitive_Subps;
with Extraction.Project_Files;
with Extraction.References_Of_Decls;
with Extraction.Renamings;
with Extraction.Source_Files_From_Projects;
with Extraction.Subp_Overrides;
with Extraction.Decl_Types;
with Extraction.Utilities;
with Extraction.With_Clauses;

package body Extraction is

   --  TODO: Improve node naming such that line numbers are not needed
   --  TODO: Relate arguments in generic instantiations with formal parameters
   --        of generics

   use type VFS.Filesystem_String;
   use type VFS.Virtual_File;

   function Node_Attributes return GW.Attribute_Definition_Sets.Map renames
     Node_Edge_Types.Node_Attributes;

   function Edge_Attributes return GW.Attribute_Definition_Sets.Map renames
     Node_Edge_Types.Edge_Attributes;

   procedure Extract_Dependency_Graph
     (Project_Filename : String; Recurse_Projects : Boolean;
      Directory_Prefix : VFS.Virtual_File; Graph_File : in out GW.GraphML_File)
   is
      Context : constant Utilities.Project_Context :=
        Utilities.Open_Project (Project_Filename);
      Projects : constant Utilities.Project_Vectors.Vector :=
        Utilities.Get_Projects (Context, Recurse_Projects);
      Units : constant Utilities.Analysis_Unit_Vectors.Vector :=
        Utilities.Open_Analysis_Units (Context, Recurse_Projects);
      Graph : constant Graph_Operations.Graph_Context :=
        Graph_Operations.Create_Graph_Context
          (Graph_File'Unchecked_Access, Directory_Prefix, Context);

      procedure Handle_Exception
        (E : Ada.Exceptions.Exception_Occurrence; Node : LAL.Ada_Node'Class);
      procedure Handle_Exception
        (E : Ada.Exceptions.Exception_Occurrence; Node : LAL.Ada_Node'Class)
      is
         Message : constant String := Ada.Exceptions.Exception_Message (E);
      begin
         if not Ada.Strings.Equal_Case_Insensitive (Message, "memoized error")
         then
            Ada.Text_IO.Put_Line
              ("Encountered Libadalang problem: " & Message);
            Node.Print;
         end if;
      end Handle_Exception;

      function Node_Visitor
        (Node : LAL.Ada_Node'Class) return LALCO.Visit_Status;
      function Node_Visitor
        (Node : LAL.Ada_Node'Class) return LALCO.Visit_Status
      is
      begin
         --  TODO: Remove exception block once all libadalang problems
         --        have been fixed.
         begin
            Decls.Extract_Nodes (Node, Graph);
            Subp_Overrides.Extract_Nodes (Node, Graph);
            Primitive_Subps.Extract_Nodes (Node, Graph);
            References_Of_Decls.Extract_Nodes (Node, Graph);
         exception
            when E : LALCO.Property_Error =>
               Handle_Exception (E, Node);
         end;

         return LALCO.Into;
      end Node_Visitor;

      function Edge_Visitor
        (Node : LAL.Ada_Node'Class) return LALCO.Visit_Status;
      function Edge_Visitor
        (Node : LAL.Ada_Node'Class) return LALCO.Visit_Status
      is
      begin
         --  TODO: Remove exception block once all libadalang problems
         --        have been fixed.
         begin
            Decls.Extract_Edges (Node, Graph);
            Subp_Overrides.Extract_Edges (Node, Graph);
            Primitive_Subps.Extract_Edges (Node, Graph);
            Generic_Instantiations.Extract_Edges (Node, Graph);
            References_Of_Decls.Extract_Edges (Node, Graph);
            Bodies_For_Decls.Extract_Edges (Node, Graph);
            Bodies_For_Entries.Extract_Edges (Node, Graph);
            Renamings.Extract_Edges (Node, Graph);
            Direct_Calls.Extract_Edges (Node, Graph);
            With_Clauses.Extract_Edges (Node, Graph);
            Derived_Type_Defs.Extract_Edges (Node, Graph);
            Decl_Types.Extract_Edges (Node, Graph);
            Deferred_Constants.Extract_Edges (Node, Graph);
         exception
            when E : LALCO.Property_Error =>
               Handle_Exception (E, Node);
         end;

         return LALCO.Into;
      end Edge_Visitor;

   begin
      --  Node extraction

      --  File_System.Extract_Nodes should occur before the extraction of any
      --  other kind of node (see also the implementation of
      --  Get_Node_Attributes in Extraction.Node_Edge_Types).
      if Directory_Prefix /= VFS.No_File then
         File_System.Extract_Nodes (Directory_Prefix, Graph);
      end if;

      for Project of Projects loop
         Ada.Text_IO.Put_Line
           ("-- " & (+Project.Project_Path.Full_Name) & " --");
         Project_Files.Extract_Nodes (Project, Graph);
         Source_Files_From_Projects.Extract_Nodes (Project, Graph);
      end loop;

      for Unit of Units loop
         Ada.Text_IO.Put_Line ("-- " & Unit.Get_Filename & " --");
         Unit.Root.Traverse (Node_Visitor'Access);
      end loop;

      --  Edge extraction.

      if Directory_Prefix /= VFS.No_File then
         File_System.Extract_Edges (Directory_Prefix, Graph);
      end if;

      for Project of Projects loop
         Ada.Text_IO.Put_Line
           ("== " & (+Project.Project_Path.Full_Name) & " ==");
         Project_Files.Extract_Edges (Project, Recurse_Projects, Graph);
         Source_Files_From_Projects.Extract_Edges
           (Project, Context, Recurse_Projects, Graph);
      end loop;

      for Unit of Units loop
         Ada.Text_IO.Put_Line ("== " & Unit.Get_Filename & " ==");
         Unit.Root.Traverse (Edge_Visitor'Access);
      end loop;
   end Extract_Dependency_Graph;

end Extraction;