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 / par-load.adb < prev    next >
Text File  |  1996-09-28  |  11KB  |  274 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                             P A R . L O A D                              --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.36 $                             --
  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. --  The Par.Load procedure loads all units that are definitely required before
  26. --  it makes any sense at all to proceed with semantic analysis, including
  27. --  with'ed units, corresponding specs for bodies, parents of child specs,
  28. --  and parents of subunits. All these units are loaded and pointers installed
  29. --  in the tree as described in the spec of package Lib.
  30.  
  31. with Fname;    use Fname;
  32. with Lib.Load; use Lib.Load;
  33. with Uname;    use Uname;
  34. with Namet;    use Namet;
  35. with Casing;   use Casing;
  36. with Osint;    use Osint;
  37. with Sem_Dist; use Sem_Dist;
  38.  
  39. separate (Par)
  40. procedure Load is
  41.  
  42.    File_Name : File_Name_Type;
  43.    --  Name of file for current unit, derived from unit name
  44.  
  45.    Cur_Unum : Unit_Number_Type := Current_Source_Unit;
  46.    --  Unit number of unit that we just finished parsing. Note that we need
  47.    --  to capture this, because Source_Unit will change as we parse new
  48.    --  source files in the multiple main source file case.
  49.  
  50.    Curunit : constant Node_Id := Cunit (Cur_Unum);
  51.    --  Compilation unit node for current compilation unit
  52.  
  53.    Loc : constant Source_Ptr := Sloc (Curunit);
  54.    --  Source location for compilation unit node
  55.  
  56.    With_Cunit : Node_Id;
  57.    --  Compilation unit node for withed unit
  58.  
  59.    Context_Node : Node_Id;
  60.    --  Next node in context items list
  61.  
  62.    With_Node : Node_Id;
  63.    --  N_With_Clause node
  64.  
  65.    Spec_Name : Unit_Name_Type;
  66.    --  Unit name of required spec
  67.  
  68.    Body_Name : Unit_Name_Type;
  69.    --  Unit name of corresponding body
  70.  
  71.    Unum : Unit_Number_Type;
  72.    --  Unit number of loaded unit
  73.  
  74.    Spec_Node : Node_Id;
  75.    --  Package spec node
  76.  
  77.    function Same_File_Name_Except_For_Case
  78.      (Expected_File_Name : File_Name_Type;
  79.       Actual_File_Name   : File_Name_Type)
  80.       return               Boolean;
  81.    --  Given an actual file name and an expected file name (the latter being
  82.    --  derived from the unit name), determine if they are the same except for
  83.    --  possibly different casing of letters.
  84.  
  85.    function Same_File_Name_Except_For_Case
  86.      (Expected_File_Name : File_Name_Type;
  87.       Actual_File_Name   : File_Name_Type)
  88.       return               Boolean
  89.    is
  90.    begin
  91.       Get_Name_String (Actual_File_Name);
  92.       Set_Casing (All_Lower_Case);
  93.  
  94.       declare
  95.          Lower_Case_Actual_File_Name : String (1 .. Name_Len);
  96.  
  97.       begin
  98.          Lower_Case_Actual_File_Name := Name_Buffer (1 .. Name_Len);
  99.          Get_Name_String (Expected_File_Name);
  100.          return Lower_Case_Actual_File_Name = Name_Buffer (1 .. Name_Len);
  101.       end;
  102.  
  103.    end Same_File_Name_Except_For_Case;
  104.  
  105. --  Start of processing for Load
  106.  
  107. begin
  108.    --  Don't do any loads if we already had a fatal error
  109.  
  110.    if Fatal_Error (Cur_Unum) then
  111.       return;
  112.    end if;
  113.  
  114.    --  First step, make sure that the unit name matches the file name
  115.    --  and issue a warning message if not. We only output this for the
  116.    --  main unit, since for other units it is more serious and is
  117.    --  caught in a separate test below.
  118.  
  119.    File_Name := Get_File_Name (Unit_Name (Cur_Unum));
  120.  
  121.    if Cur_Unum = Main_Unit
  122.      and then File_Name /= Unit_File_Name (Cur_Unum)
  123.      and then (File_Names_Case_Sensitive
  124.                 or not Same_File_Name_Except_For_Case
  125.                          (File_Name, Unit_File_Name (Cur_Unum)))
  126.    then
  127.       Error_Msg_Name_1 := File_Name;
  128.       Error_Msg ("?file name does not match unit name, should be{", Loc);
  129.    end if;
  130.  
  131.    --  For units other than the main unit, the expected unit name is set and
  132.    --  must be the same as the actual unit name, or we are in big trouble, and
  133.    --  abandon the compilation since there are situations where this really
  134.    --  gets us into bad trouble (e.g. some subunit situations).
  135.  
  136.    if Cur_Unum /= Main_Unit
  137.      and then Expected_Unit (Cur_Unum) /= Unit_Name (Cur_Unum)
  138.    then
  139.       Error_Msg_Name_1 := Unit_File_Name (Cur_Unum);
  140.       Error_Msg ("file { does not contain expected unit!", Loc);
  141.       Error_Msg_Unit_1 := Expected_Unit (Cur_Unum);
  142.       Error_Msg ("expected unit $!", Loc);
  143.       Error_Msg_Unit_1 := Unit_Name (Cur_Unum);
  144.       Error_Msg ("found unit $!", Loc);
  145.       raise Unrecoverable_Error;
  146.    end if;
  147.  
  148.    --  If current unit is a body, load its corresponding spec
  149.  
  150.    if Nkind (Unit (Curunit)) = N_Package_Body
  151.      or else Nkind (Unit (Curunit)) = N_Subprogram_Body
  152.    then
  153.       Spec_Name := Get_Spec_Name (Unit_Name (Cur_Unum));
  154.       Unum := Load_Unit (Spec_Name, False, Curunit);
  155.  
  156.       --  If we successfully load the unit, then set the spec pointer. Once
  157.       --  again note that if the loaded unit has a fatal error, Load will
  158.       --  have set our Fatal_Error flag to propagate this condition.
  159.  
  160.       if Unum /= No_Unit then
  161.          Set_Library_Unit (Curunit, Cunit (Unum));
  162.  
  163.       --  If we don't find the spec, then if we have a subprogram body, we
  164.       --  are still OK, we just have a case of a body acting as its own spec
  165.  
  166.       elsif Nkind (Unit (Curunit)) = N_Subprogram_Body then
  167.          Set_Acts_As_Spec (Curunit, True);
  168.          Set_Library_Unit (Curunit, Curunit);
  169.  
  170.       --  Otherwise we do have an error, repeat the load request for the spec
  171.       --  with Required set True to generate an appropriate error message.
  172.  
  173.       else
  174.          Unum := Load_Unit (Spec_Name, True, Curunit);
  175.       end if;
  176.  
  177.    --  If current unit is a child unit spec, load its parent
  178.  
  179.    elsif Nkind (Unit (Curunit)) = N_Package_Declaration
  180.      or else Nkind (Unit (Curunit)) =  N_Subprogram_Declaration
  181.      or else Nkind (Unit (Curunit)) in N_Generic_Declaration
  182.      or else Nkind (Unit (Curunit)) in N_Generic_Instantiation
  183.      or else Nkind (Unit (Curunit)) in N_Renaming_Declaration
  184.    then
  185.       Spec_Name := Get_Parent_Spec_Name (Unit_Name (Cur_Unum));
  186.  
  187.       if Spec_Name /= No_Name then
  188.          Unum := Load_Unit (Spec_Name, True, Curunit);
  189.  
  190.          if Unum /= No_Unit then
  191.             Set_Parent_Spec (Unit (Curunit), Cunit (Unum));
  192.          end if;
  193.       end if;
  194.  
  195.    --  If current unit is a subunit, then load its parent body
  196.  
  197.    elsif Nkind (Unit (Curunit)) = N_Subunit then
  198.       Body_Name := Get_Parent_Body_Name (Unit_Name (Cur_Unum));
  199.       Unum := Load_Unit (Body_Name, True, Curunit);
  200.  
  201.       if Unum /= No_Unit then
  202.          Set_Library_Unit (Curunit, Cunit (Unum));
  203.       end if;
  204.  
  205.    end if;
  206.  
  207.    --  If current unit is an RCI or remote types spec, then append to
  208.    --  Context_Items System.RPC
  209.  
  210.    if Nkind (Unit (Curunit)) = N_Package_Declaration then
  211.       Append_System_RPC (Curunit);
  212.    end if;
  213.  
  214.    --  Now we load with'ed units, loop through context items
  215.  
  216.    Context_Node := First (Context_Items (Curunit));
  217.    while Present (Context_Node) loop
  218.  
  219.       if Nkind (Context_Node) = N_With_Clause then
  220.          With_Node := Context_Node;
  221.          Spec_Name := Get_Unit_Name (With_Node);
  222.  
  223.          Unum := Load_Unit (Spec_Name, False, With_Node);
  224.  
  225.          --  If we find the unit, then set spec pointer in the N_With_Clause
  226.          --  to point to the compilation unit for the spec. Remember that
  227.          --  the Load routine itself sets our Fatal_Error flag if the loaded
  228.          --  unit gets a fatal error, so we don't need to worry about that.
  229.  
  230.          if Unum /= No_Unit then
  231.             Set_Library_Unit (With_Node, Cunit (Unum));
  232.  
  233.             --  In case withed unit is RCI or remote types then append
  234.             --  System.RPC.Partition_Interface to current unit context
  235.             --  items.
  236.  
  237.             Append_System_RPC_PI (Curunit, Cunit (Unum));
  238.  
  239.          --  If the spec isn't found, then try finding the corresponding
  240.          --  body, since it is possible that we have a subprogram body
  241.          --  that is acting as a spec (since no spec is present).
  242.  
  243.          else
  244.             Body_Name := Get_Body_Name (Spec_Name);
  245.             Unum := Load_Unit (Body_Name, False, With_Node);
  246.  
  247.             --  If we got a subprogram body, then mark that we are using
  248.             --  the body as a spec in the file table, and set the spec
  249.             --  pointer in the N_With_Clause to point to the body entity.
  250.  
  251.             if Unum /= No_Unit
  252.               and then Nkind (Unit (Cunit (Unum))) = N_Subprogram_Body
  253.             then
  254.                With_Cunit := Cunit (Unum);
  255.                Set_Library_Unit (With_Node, With_Cunit);
  256.                Set_Acts_As_Spec (With_Cunit, True);
  257.                Set_Library_Unit (With_Cunit, With_Cunit);
  258.  
  259.             --  If we couldn't find the body, or if it wasn't a body spec
  260.             --  then we are in trouble. We make one more call to Load to
  261.             --  require the spec. We know it will fail of course, the
  262.             --  purpose is to generate the required error message (we prefer
  263.             --  that this message refer to the missing spec, not the body)
  264.  
  265.             else
  266.                Unum := Load_Unit (Spec_Name, True, With_Node);
  267.             end if;
  268.          end if;
  269.       end if;
  270.  
  271.       Context_Node := Next (Context_Node);
  272.    end loop;
  273. end Load;
  274.