home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / lib-load.adb < prev    next >
Text File  |  1996-09-28  |  15KB  |  414 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                             L I B . L O A D                              --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.43 $                             --
  10. --                                                                          --
  11. --        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. with Atree;    use Atree;
  26. with Debug;    use Debug;
  27. with Errout;   use Errout;
  28. with Fname;    use Fname;
  29. with Osint;    use Osint;
  30. with Output;   use Output;
  31. with Par;
  32. with Scn;      use Scn;
  33. with Sinfo;    use Sinfo;
  34. with Sinput;   use Sinput;
  35. with Sinput.L; use Sinput.L;
  36. with Uname;    use Uname;
  37.  
  38. package body Lib.Load is
  39.  
  40.    -----------------------
  41.    -- Local Subprograms --
  42.    -----------------------
  43.  
  44.    procedure Write_Dependency_Chain;
  45.    --  This procedure is used to generate error message info lines that
  46.    --  trace the current dependency chain when a load error occurs.
  47.  
  48.    function Version_Init (U : Unit_Number_Type) return Version_Id;
  49.    --  Calculate initial value of version from time stamp value
  50.  
  51.    ----------------
  52.    -- Initialize --
  53.    ----------------
  54.  
  55.    procedure Initialize is
  56.       Fname : File_Name_Type;
  57.  
  58.    begin
  59.       Units.Init;
  60.       Load_Stack.Init;
  61.       Load_Stack.Increment_Last;
  62.       Load_Stack.Table (Load_Stack.Last) := Main_Unit;
  63.  
  64.       --  Initialize unit table entry for Main_Unit. Note that we don't know
  65.       --  the unit name yet, that gets filled in when the parser parses the
  66.       --  main unit, at which time a check is made that it matches the main
  67.       --  file name, and then the Unit_Name field is set. The Cunit and
  68.       --  Cunit_Entity fields also get filled in later by the parser.
  69.  
  70.       Units.Increment_Last;
  71.       Fname := Next_Main_Source;
  72.  
  73.       Units.Table (Main_Unit).Unit_File_Name := Fname;
  74.  
  75.       if Fname /= No_File then
  76.          Units.Table (Main_Unit).Unit_Name     := No_Name;
  77.          Units.Table (Main_Unit).Expected_Unit := No_Name;
  78.          Units.Table (Main_Unit).Source_Index  := Load_Source_File (Fname);
  79.          Units.Table (Main_Unit).Loading       := True;
  80.          Units.Table (Main_Unit).Cunit         := Empty;
  81.          Units.Table (Main_Unit).Cunit_Entity  := Empty;
  82.          Units.Table (Main_Unit).Fatal_Error   := False;
  83.          Units.Table (Main_Unit).Generate_Code := False;
  84.          Units.Table (Main_Unit).Main_Priority := Default_Main_Priority;
  85.          Units.Table (Main_Unit).Version       := Version_Init (Main_Unit);
  86.          Units.Table (Main_Unit).Serial_Number := 0;
  87.       end if;
  88.    end Initialize;
  89.  
  90.    ---------------
  91.    -- Load_Unit --
  92.    ---------------
  93.  
  94.    function Load_Unit
  95.      (Uname    : Unit_Name_Type;
  96.       Required : Boolean;
  97.       Enode    : Node_Id)
  98.       return     Unit_Number_Type
  99.    is
  100.       Calling_Unit : Unit_Number_Type;
  101.       Unum         : Unit_Number_Type;
  102.       Fname        : File_Name_Type := Get_File_Name (Uname);
  103.       Src_Ind      : Source_File_Index;
  104.  
  105.    begin
  106.       if Debug_Flag_L then
  107.          Write_Str ("*** Load request for unit: ");
  108.          Write_Unit_Name (Uname);
  109.  
  110.          if Required then
  111.             Write_Str (" (Required = True)");
  112.          else
  113.             Write_Str (" (Required = False)");
  114.          end if;
  115.  
  116.          Write_Eol;
  117.       end if;
  118.  
  119.       --  Capture error location if it is for the main unit. The idea is to
  120.       --  post errors on the main unit location, not the most recent unit.
  121.  
  122.       if Present (Enode)
  123.         and then Get_Sloc_Unit_Number (Sloc (Enode)) = Main_Unit
  124.       then
  125.          Load_Msg_Sloc := Sloc (Enode);
  126.       end if;
  127.  
  128.       --  If we are generating error messages, then capture calling unit
  129.  
  130.       if Present (Enode) then
  131.          Calling_Unit := Get_Sloc_Unit_Number (Sloc (Enode));
  132.       end if;
  133.  
  134.       --  See if we already have an entry for this unit
  135.  
  136.       Unum := Main_Unit;
  137.  
  138.       while Unum <= Units.Last loop
  139.          exit when Uname = Units.Table (Unum).Unit_Name;
  140.          Unum := Unum + 1;
  141.       end loop;
  142.  
  143.       --  Whether or not the entry was found, Unum is now the right value,
  144.       --  since it is one more than Units.Last (i.e. the index of the new
  145.       --  entry we will create) in the not found case.
  146.  
  147.       --  A special check is necessary in the unit not found case. If the unit
  148.       --  is not found, but the file in which it lives has already been loaded,
  149.       --  then we have the problem that the file does not contain the unit that
  150.       --  is needed. We simply treat this as a file not found condition.
  151.  
  152.       if Unum > Units.Last then
  153.          for J in Units.First .. Units.Last loop
  154.             if Fname = Units.Table (J).Unit_File_Name then
  155.                if Debug_Flag_L then
  156.                   Write_Str ("*** File does not contain unit, Unit_Number = ");
  157.                   Write_Int (Int (Unum));
  158.                   Write_Eol;
  159.                end if;
  160.  
  161.                if Present (Enode) then
  162.                   Error_Msg_Unit_1 := Uname;
  163.  
  164.                   if Is_Language_Defined_Unit (Fname) then
  165.                      Error_Msg
  166.                        ("$ is not a language defined unit", Load_Msg_Sloc);
  167.                   else
  168.                      Error_Msg_Name_1 := Fname;
  169.                      Error_Msg
  170.                        ("File{ does not contain unit$", Load_Msg_Sloc);
  171.                   end if;
  172.  
  173.                   Write_Dependency_Chain;
  174.                   raise Unrecoverable_Error;
  175.  
  176.                else
  177.                   return No_Unit;
  178.                end if;
  179.             end if;
  180.          end loop;
  181.       end if;
  182.  
  183.       --  If we are proceeding with load, then make load stack entry
  184.  
  185.       Load_Stack.Increment_Last;
  186.       Load_Stack.Table (Load_Stack.Last) := Unum;
  187.  
  188.       --  Case of entry already in table
  189.  
  190.       if Unum <= Units.Last then
  191.  
  192.          --  Here is where we check for a circular dependency, which is
  193.          --  an attempt to load a unit which is currently in the process
  194.          --  of being loaded. We do *not* care about a circular chain that
  195.          --  leads back to a body, because this kind of circular dependence
  196.          --  legitimately occurs (e.g. two package bodies that contain
  197.          --  inlined subprogram referenced by the other).
  198.  
  199.          if Loading (Unum)
  200.            and then (Is_Spec_Name (Units.Table (Unum).Unit_Name)
  201.                        or else Acts_As_Spec (Units.Table (Unum).Cunit))
  202.          then
  203.             if Debug_Flag_L then
  204.                Write_Str ("*** Circular dependency encountered");
  205.                Write_Eol;
  206.             end if;
  207.  
  208.             if Present (Enode) then
  209.                Error_Msg ("Circular unit dependency", Load_Msg_Sloc);
  210.                Write_Dependency_Chain;
  211.                raise Unrecoverable_Error;
  212.             else
  213.                Load_Stack.Decrement_Last;
  214.                return No_Unit;
  215.             end if;
  216.          end if;
  217.  
  218.          if Debug_Flag_L then
  219.             Write_Str ("*** Unit already in file table, Unit_Number = ");
  220.             Write_Int (Int (Unum));
  221.             Write_Eol;
  222.          end if;
  223.  
  224.          Load_Stack.Decrement_Last;
  225.          return Unum;
  226.  
  227.       --  File is not already in table, so try to open it
  228.  
  229.       else
  230.          Src_Ind := Load_Source_File (Fname);
  231.  
  232.          --  Make a partial entry in the file table, used even in the file not
  233.          --  found case to print the dependency chain including the last entry
  234.  
  235.          Units.Increment_Last;
  236.          Units.Table (Unum).Unit_Name := Uname;
  237.  
  238.          --  File was found
  239.  
  240.          if Src_Ind /= No_Source_File then
  241.             if Debug_Flag_L then
  242.                Write_Str ("*** Building new unit table entry, Unit_Number = ");
  243.                Write_Int (Int (Unum));
  244.                Write_Eol;
  245.             end if;
  246.  
  247.             Units.Table (Unum).Expected_Unit  := Uname;
  248.             Units.Table (Unum).Unit_File_Name := Fname;
  249.             Units.Table (Unum).Source_Index   := Src_Ind;
  250.             Units.Table (Unum).Cunit          := Empty;
  251.             Units.Table (Unum).Cunit_Entity   := Empty;
  252.             Units.Table (Unum).Fatal_Error    := False;
  253.             Units.Table (Unum).Generate_Code  := False;
  254.             Units.Table (Unum).Main_Priority  := Default_Main_Priority;
  255.             Units.Table (Unum).Serial_Number  := 0;
  256.             Units.Table (Unum).Version        := Version_Init (Unum);
  257.  
  258.             --  Parse the new unit
  259.  
  260.             Set_Loading (Unum, True);
  261.             Initialize_Scanner (Unum);
  262.             Par;
  263.             Set_Loading (Unum, False);
  264.  
  265.             if Debug_Flag_L then
  266.                Write_Str ("*** Load completed successfully, Unit_Number = ");
  267.                Write_Int (Int (Unum));
  268.                Write_Eol;
  269.             end if;
  270.  
  271.             --  If loaded unit had a fatal error, then caller inherits it!
  272.  
  273.             if Units.Table (Unum).Fatal_Error
  274.               and then Present (Enode)
  275.             then
  276.                Units.Table (Calling_Unit).Fatal_Error := True;
  277.             end if;
  278.  
  279.             --  Remove load stack entry and return the entry in the file table
  280.  
  281.             Load_Stack.Decrement_Last;
  282.             return Unum;
  283.  
  284.          --  Case of file not found
  285.  
  286.          else
  287.             if Debug_Flag_L then
  288.                Write_Str ("*** File was not found, Unit_Number = ");
  289.                Write_Int (Int (Unum));
  290.                Write_Eol;
  291.             end if;
  292.  
  293.             --  Generate message if unit required
  294.  
  295.             if Required and then Present (Enode) then
  296.  
  297.                if Is_Language_Defined_Unit (Fname) then
  298.                   Error_Msg_Unit_1 := Uname;
  299.                   Error_Msg
  300.                     ("$ is not a language defined unit", Load_Msg_Sloc);
  301.  
  302.                else
  303.                   Error_Msg_Name_1 := Fname;
  304.                   Error_Msg ("file{ not found", Load_Msg_Sloc);
  305.                end if;
  306.  
  307.                Write_Dependency_Chain;
  308.                raise Unrecoverable_Error;
  309.  
  310.             --  If unit not required, remove load stack entry and the junk
  311.             --  file table entry, and return No_Unit to indicate not found,
  312.  
  313.             else
  314.                Load_Stack.Decrement_Last;
  315.                Units.Decrement_Last;
  316.                return No_Unit;
  317.             end if;
  318.          end if;
  319.       end if;
  320.    end Load_Unit;
  321.  
  322.    ------------------------
  323.    -- Make_Instance_Unit --
  324.    ------------------------
  325.  
  326.    --  If the unit is an instance, it appears as a package declaration, but
  327.    --  contains both declaration and body of the instance. The body becomes
  328.    --  the main unit of the compilation, and the declaration is inserted
  329.    --  at the end of the unit table. The main unit now has the name of a
  330.    --  body, which is constructed from the name of the original spec,
  331.    --  and is attached to the compilation node of the original unit.
  332.    --  The declaration has been attached to a new compilation unit node, and
  333.    --  code will have to be generated for it.
  334.  
  335.    procedure Make_Instance_Unit (N : Node_Id) is
  336.    begin
  337.       Units.Increment_Last;
  338.  
  339.       Units.Table (Units.Last)               := Units.Table (Main_Unit);
  340.       Units.Table (Units.Last).Cunit         := Library_Unit (N);
  341.       Units.Table (Units.Last).Generate_Code := True;
  342.  
  343.       Units.Table (Main_Unit).Cunit          := N;
  344.       Units.Table (Main_Unit).Unit_Name
  345.          := Get_Body_Name (Get_Unit_Name (Unit (Library_Unit (N))));
  346.       Units.Table (Main_Unit).Version        := Version_Init (Main_Unit);
  347.    end Make_Instance_Unit;
  348.  
  349.    ------------------
  350.    -- Version_Init --
  351.    ------------------
  352.  
  353.    function Version_Init (U : Unit_Number_Type) return Version_Id is
  354.       TS : constant Time_Stamp_Type := Time_Stamp (Source_Index (U));
  355.       V  : Version_Id := 0;
  356.  
  357.    begin
  358.       for J in TS'Range loop
  359.          V := V * 8;
  360.          V := V + (Character'Pos (TS (J)) - Character'Pos ('0'));
  361.       end loop;
  362.  
  363.       return V;
  364.    end Version_Init;
  365.  
  366.    --------------------
  367.    -- Version_Update --
  368.    --------------------
  369.  
  370.    procedure Version_Update (U : Node_Id; From : Node_Id) is
  371.       Unum  : constant Unit_Number_Type := Get_Cunit_Unit_Number (U);
  372.       Fnum  : constant Unit_Number_Type := Get_Cunit_Unit_Number (From);
  373.       UV    : Version_Id;
  374.       FV    : Version_Id;
  375.       Carry : Boolean;
  376.  
  377.    begin
  378.       --  The hash code is evolved by doing a 1's complement addition, i.e.
  379.       --  an add with an end around carry (we don't want bits wandering away
  380.       --  at the high order end.
  381.  
  382.       --  Note that an xor would be inappropriate, because the same unit can
  383.       --  get included in the hash sum many times (for example if this unit
  384.       --  with's two units that are themselves both semantically dependent
  385.       --  on a third unit), so if we did an xor, and there was an even number
  386.       --  of such duplications we would lose the contribution from that unit.
  387.  
  388.       UV := Units.Table (Unum).Version;
  389.       FV := Units.Table (Fnum).Version;
  390.       Carry := (UV >= (2 ** 31)) and then (FV >= (2 ** 31));
  391.       Units.Table (Unum).Version := UV + FV + Boolean'Pos (Carry);
  392.    end Version_Update;
  393.  
  394.    ----------------------------
  395.    -- Write_Dependency_Chain --
  396.    ----------------------------
  397.  
  398.    procedure Write_Dependency_Chain is
  399.    begin
  400.       --  The dependency chain is only written if it is at least two entries
  401.       --  deep, otherwise it is trivial (the main unit depending on a unit
  402.       --  that it obviously directly depends on).
  403.  
  404.       if Load_Stack.Last - 1 > Load_Stack.First then
  405.          for U in Load_Stack.First .. Load_Stack.Last - 1 loop
  406.             Error_Msg_Unit_1 := Unit_Name (Load_Stack.Table (U));
  407.             Error_Msg_Unit_2 := Unit_Name (Load_Stack.Table (U + 1));
  408.             Error_Msg ("$ depends on $!", Load_Msg_Sloc);
  409.          end loop;
  410.       end if;
  411.    end Write_Dependency_Chain;
  412.  
  413. end Lib.Load;
  414.