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 / bindgen.adb < prev    next >
Text File  |  1996-09-28  |  11KB  |  342 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                              B I N D G E N                               --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.39 $                             --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 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 ALI;    use ALI;
  26. with Binde;  use Binde;
  27. with Namet;  use Namet;
  28. with Opt;    use Opt;
  29. with Osint;  use Osint;
  30. with Types;  use Types;
  31.  
  32. package body Bindgen is
  33.  
  34.    Statement_Buffer : String (1 .. 1000);
  35.    --  Buffer used for constructing output statements
  36.  
  37.    With_Finalization : Boolean := False;
  38.    --  Flag which indicates whether the program use finalization
  39.    --  (presence of the unit System.Finalization_Implementation)
  40.  
  41.    -----------------------
  42.    -- Local Subprograms --
  43.    -----------------------
  44.  
  45.    procedure Gen_Elab_Calls;
  46.    --  Generate sequence of elaboration calls
  47.  
  48.    procedure Gen_Main_Program_File;
  49.    --  Generate lines for output file in main program case
  50.  
  51.    procedure Gen_Non_Main_Program_File;
  52.    --  Generate lines for output file in non-main program case
  53.  
  54.    procedure List_Object_Files_Options;
  55.    --  Output a comment containing a list of the full names of the object
  56.    --  files to be linked and the list of linker options supplised by
  57.    --  Linker_Options pragmas in the source.
  58.  
  59.    procedure List_Versions;
  60.    --  Output series of definitions for unit versions
  61.  
  62.    ---------------------
  63.    -- Gen_Output_File --
  64.    ---------------------
  65.  
  66.    procedure Gen_Output_File is
  67.    begin
  68.       Create_Binder_Output;
  69.  
  70.       if Bind_Main_Program then
  71.          Gen_Main_Program_File;
  72.       else
  73.          Gen_Non_Main_Program_File;
  74.       end if;
  75.  
  76.       Close_Binder_Output;
  77.    end Gen_Output_File;
  78.  
  79.    --------------------
  80.    -- Gen_Elab_Calls --
  81.    --------------------
  82.  
  83.    procedure Gen_Elab_Calls is
  84.       L   : Natural;
  85.       Col : Natural;
  86.  
  87.    begin
  88.       for E in Elab_Order.First .. Elab_Order.Last loop
  89.          Get_Name_String (Unit.Table (Elab_Order.Table (E)).Uname);
  90.  
  91.          --  if the program uses finalization we must make sure to finalize
  92.          --  global objects too at the end of the program.
  93.  
  94.          if Name_Buffer (1 .. 34) = "system.finalization_implementation" then
  95.             With_Finalization := True;
  96.          end if;
  97.  
  98.          --  Generate elaboration call if elaboration needed
  99.  
  100.          if not Unit.Table (Elab_Order.Table (E)).No_Elab then
  101.             Statement_Buffer (1 .. 3) := "   ";
  102.  
  103.             --  Copy the unit name (and replace '.' by '__' for child unit)
  104.  
  105.             L := 4;
  106.  
  107.             for J in 1 .. Name_Len - 2 loop
  108.                if Name_Buffer (J) /= '.' then
  109.                   Statement_Buffer (L) := Name_Buffer (J);
  110.                   L := L + 1;
  111.                else
  112.                   Statement_Buffer (L .. L + 1) := "__";
  113.                   L := L + 2;
  114.                end if;
  115.             end loop;
  116.  
  117.             --  Complete call to elaboration routine
  118.  
  119.             Statement_Buffer (L .. L + 6) := "___elab";
  120.             Statement_Buffer (L + 7) := Name_Buffer (Name_Len);
  121.             Statement_Buffer (L + 8 .. L + 11) := " ();";
  122.             L := L + 11;
  123.             Write_Binder_Info (Statement_Buffer (1 .. L));
  124.          end if;
  125.       end loop;
  126.    end Gen_Elab_Calls;
  127.  
  128.    ---------------------------
  129.    -- Gen_Main_Program_File --
  130.    ---------------------------
  131.  
  132.    procedure Gen_Main_Program_File is
  133.    begin
  134.       --  Generate __main_priority function
  135.  
  136.       declare
  137.          Ctr : Integer;
  138.          P   : Int;
  139.  
  140.          procedure Set_Int (N : Nat);
  141.          --  Set given value in decimal in Statement_Buffer with no spaces
  142.  
  143.          procedure Set_Int (N : Nat) is
  144.          begin
  145.             if N > 9 then
  146.                Set_Int (N / 10);
  147.             else
  148.                Statement_Buffer (Ctr) :=
  149.                  Character'Val (N mod 10 + Character'Pos ('0'));
  150.                Ctr := Ctr + 1;
  151.             end if;
  152.          end Set_Int;
  153.  
  154.       begin
  155.          Write_Binder_Info ("int");
  156.          Write_Binder_Info ("__main_priority ()");
  157.          Write_Binder_Info ("{");
  158.          Statement_Buffer (1 .. 9) := "  return ";
  159.          Ctr := 10;
  160.          P := ALIs.Table (ALIs.First).Main_Priority;
  161.  
  162.          if P < 0 then
  163.             P := -P;
  164.             Statement_Buffer (Ctr) := '-';
  165.             Ctr := Ctr + 1;
  166.          end if;
  167.  
  168.          Set_Int (P);
  169.          Statement_Buffer (Ctr) := ';';
  170.          Write_Binder_Info (Statement_Buffer (1 .. Ctr));
  171.          Write_Binder_Info ("}");
  172.       end;
  173.  
  174.       Write_Binder_Info ("extern int gnat_argc;");
  175.       Write_Binder_Info ("extern char **gnat_argv;");
  176.       Write_Binder_Info ("extern int gnat_exit_status;");
  177.  
  178.       --  Generate main
  179.       --  (which gcc bitches about if it returns anything but int)
  180.  
  181.       if ALIs.Table (ALIs.First).Main_Program = Proc then
  182.          Write_Binder_Info ("int main (argc, argv)");
  183.       else
  184.          Write_Binder_Info ("int main (argc, argv)");
  185.       end if;
  186.  
  187.       Write_Binder_Info ("    int argc;");
  188.       Write_Binder_Info ("    char **argv;");
  189.       Write_Binder_Info ("{");
  190.       Write_Binder_Info ("   gnat_argc = argc;");
  191.       Write_Binder_Info ("   gnat_argv = argv;");
  192.       Write_Binder_Info (" ");
  193.  
  194.       Write_Binder_Info ("   __gnat_initialize();");
  195.  
  196.       Gen_Elab_Calls;
  197.  
  198.       Write_Binder_Info (" ");
  199.       Get_Name_String (Unit.Table (First_Unit_Entry).Uname);
  200.  
  201.       --  Main program is procedure case
  202.  
  203.       if ALIs.Table (ALIs.First).Main_Program = Proc then
  204.          Statement_Buffer (1 .. 8) := "   _ada_";
  205.          Statement_Buffer (9 .. Name_Len + 6) :=
  206.            Name_Buffer (1 .. Name_Len - 2);
  207.          Statement_Buffer (Name_Len + 7 .. Name_Len + 10) := " ();";
  208.          Write_Binder_Info (Statement_Buffer (1 .. Name_Len + 10));
  209.  
  210.       --  Main program is function case
  211.  
  212.       else -- ALIs.Table (ALIs_First).Main_Program = Func
  213.          Statement_Buffer (1 .. 16) := "   return (_ada_";
  214.          Statement_Buffer (17 .. Name_Len + 14) :=
  215.            Name_Buffer (1 .. Name_Len - 2);
  216.          Statement_Buffer (Name_Len + 15 .. Name_Len + 19) := " ());";
  217.          Write_Binder_Info (Statement_Buffer (1 .. Name_Len + 19));
  218.       end if;
  219.  
  220.       if With_Finalization then
  221.          Write_Binder_Info ("   system__finalization_implementation"
  222.            & "__finalize_global_list ();");
  223.       end if;
  224.  
  225.       Write_Binder_Info ("   __gnat_finalize();");
  226.  
  227.       Write_Binder_Info ("   exit (gnat_exit_status);");
  228.       Write_Binder_Info ("}");
  229.       List_Versions;
  230.       List_Object_Files_Options;
  231.    end Gen_Main_Program_File;
  232.  
  233.    -------------------------------
  234.    -- Gen_Non_Main_Program_File --
  235.    -------------------------------
  236.  
  237.    procedure Gen_Non_Main_Program_File is
  238.    begin
  239.       Write_Binder_Info ("void ada__bind ()");
  240.       Write_Binder_Info ("{");
  241.       Gen_Elab_Calls;
  242.       Write_Binder_Info ("}");
  243.       List_Versions;
  244.       List_Object_Files_Options;
  245.    end Gen_Non_Main_Program_File;
  246.  
  247.    -------------------------------
  248.    -- List_Object_Files_Options --
  249.    -------------------------------
  250.  
  251.    procedure List_Object_Files_Options is
  252.       Sptr : Natural;
  253.  
  254.    begin
  255.       Write_Binder_Info ("/* BEGIN Object file/option list");
  256.  
  257.       for E in Elab_Order.First .. Elab_Order.Last loop
  258.          Get_Name_String (Unit.Table (Elab_Order.Table (E)).Uname);
  259.  
  260.          --  If not spec that has an associated body, then generate a
  261.          --  comment giving the name of the corresponding ALI file
  262.  
  263.          if Unit.Table (Elab_Order.Table (E)).Utype /= Is_Spec then
  264.  
  265.             --  Now output the file name as a comment
  266.  
  267.             Get_Name_String
  268.               (ALIs.Table
  269.                 (Unit.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name);
  270.             Write_Binder_Info (Name_Buffer (1 .. Name_Len));
  271.          end if;
  272.       end loop;
  273.  
  274.       --  Write linker options
  275.  
  276.       Sptr := 0;
  277.       for J in 1 .. Linker_Options.Last loop
  278.          if Linker_Options.Table (J) = Ascii.Nul then
  279.             Write_Binder_Info (Statement_Buffer (1 .. Sptr));
  280.             Sptr := 0;
  281.          else
  282.             Sptr := Sptr + 1;
  283.             Statement_Buffer (Sptr) := Linker_Options.Table (J);
  284.          end if;
  285.       end loop;
  286.  
  287.       Write_Binder_Info ("   END Object file/option list */");
  288.    end List_Object_Files_Options;
  289.  
  290.    -------------------
  291.    -- List_Versions --
  292.    -------------------
  293.  
  294.    --  This routine generates a line of the form:
  295.  
  296.    --    unsigned unam = 0xhhhhhhhh;
  297.  
  298.    --  for each unit, where unam is the unit name suffixed by either B or
  299.    --  S for body or spec, with dots replaced by double underscores.
  300.  
  301.    procedure List_Versions is
  302.       Sptr : Natural;
  303.  
  304.    begin
  305.       for U in Unit.First .. Unit.Last loop
  306.          Statement_Buffer (1 .. 9) := "unsigned ";
  307.          Sptr := 10;
  308.  
  309.          Get_Name_String (Unit.Table (U).Uname);
  310.  
  311.          for K in 1 .. Name_Len loop
  312.             if Name_Buffer (K) = '.' then
  313.                Statement_Buffer (Sptr) := '_';
  314.                Sptr := Sptr + 1;
  315.                Name_Buffer (K) := '_';
  316.  
  317.             elsif Name_Buffer (K) = '%' then
  318.                exit;
  319.             end if;
  320.  
  321.             Statement_Buffer (Sptr) := Name_Buffer (K);
  322.             Sptr := Sptr + 1;
  323.          end loop;
  324.  
  325.          if Name_Buffer (Name_Len) = 's' then
  326.             Statement_Buffer (Sptr) := 'S';
  327.          else
  328.             Statement_Buffer (Sptr) := 'B';
  329.          end if;
  330.  
  331.          Sptr := Sptr + 1;
  332.          Statement_Buffer (Sptr .. Sptr + 4) := " = 0x";
  333.          Sptr := Sptr + 5;
  334.          Statement_Buffer (Sptr .. Sptr + 7) := Unit.Table (U).Version;
  335.          Statement_Buffer (Sptr + 8) := ';';
  336.          Write_Binder_Info (Statement_Buffer (1 .. Sptr + 8));
  337.       end loop;
  338.  
  339.    end List_Versions;
  340.  
  341. end Bindgen;
  342.