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 / fname.adb < prev    next >
Text File  |  1996-09-28  |  8KB  |  227 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                                F N A M E                                 --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.37 $                             --
  10. --                                                                          --
  11. --        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
  12. --                                                                          --
  13. -- The GNAT library is free software; you can redistribute it and/or modify --
  14. -- it under terms of the GNU Library General Public License as published by --
  15. -- the Free Software  Foundation; either version 2, or (at your option) any --
  16. -- later version.  The GNAT library is distributed in the hope that it will --
  17. -- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
  18. -- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
  19. -- Library  General  Public  License for  more  details.  You  should  have --
  20. -- received  a copy of the GNU  Library  General Public License  along with --
  21. -- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
  22. -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with Debug;    use Debug;
  27. with Krunch;
  28. with Namet;    use Namet;
  29. with Opt;      use Opt;
  30. with Widechar; use Widechar;
  31.  
  32. package body Fname is
  33.  
  34.    ----------------------------
  35.    -- Get_Expected_Unit_Type --
  36.    ----------------------------
  37.  
  38.    --  We assume that a file name whose last character is a lower case b is
  39.    --  a body and a file name whose last character is a lower case s is a
  40.    --  spec. If any other character is found (e.g. when we are in syntax
  41.    --  checking only mode, where the file name conventions are not set),
  42.    --  then we return Unknown.
  43.  
  44.    function Get_Expected_Unit_Type
  45.      (Fname : File_Name_Type)
  46.       return  Expected_Unit_Type
  47.    is
  48.    begin
  49.       Get_Name_String (Fname);
  50.  
  51.       if Name_Buffer (Name_Len) = 'b' then
  52.          return Expect_Body;
  53.       elsif Name_Buffer (Name_Len) = 's' then
  54.          return Expect_Spec;
  55.       else
  56.          return Unknown;
  57.       end if;
  58.    end Get_Expected_Unit_Type;
  59.  
  60.    -------------------
  61.    -- Get_File_Name --
  62.    -------------------
  63.  
  64.    function Get_File_Name (Uname : Unit_Name_Type) return File_Name_Type is
  65.       Unit_Char   : Character;
  66.       --  Set to 's' or 'b' for spec or body
  67.  
  68.       J : Integer;
  69.  
  70.    begin
  71.       Get_Decoded_Name_String (Uname);
  72.  
  73.       --  Change periods to hyphens, being careful to skip past any
  74.       --  period characters embedded in wide character escape sequences)
  75.  
  76.       J := 1;
  77.  
  78.       while J <= Name_Len loop
  79.          if Name_Buffer (J) = '.' then
  80.             Name_Buffer (J) := '-';
  81.             J := J + 1;
  82.  
  83.          elsif Name_Buffer (J) = Ascii.ESC
  84.            or else (Upper_Half_Encoding
  85.                      and then Name_Buffer (J) in Upper_Half_Character)
  86.          then
  87.             Skip_Wide (Name_Buffer, J);
  88.          else
  89.             J := J + 1;
  90.          end if;
  91.       end loop;
  92.  
  93.       --  Deal with spec or body suffix
  94.  
  95.       Unit_Char := Name_Buffer (Name_Len);
  96.       pragma Assert (Unit_Char = 'b' or else Unit_Char = 's');
  97.       pragma Assert (Name_Len >= 3 and then Name_Buffer (Name_Len - 1) = '%');
  98.       Name_Len := Name_Len - 2;
  99.  
  100.       --  The file name (minus the extension) to be used is stored in
  101.       --  Name_Buffer (1 .. Name_Buffer). If it's too long then crunch it.
  102.  
  103.       Krunch
  104.         (Name_Buffer,
  105.          Name_Len,
  106.          Integer (Maximum_File_Name_Length),
  107.          Debug_Flag_4);
  108.  
  109.       --  Here with the file name set and of OK length, add the extension
  110.  
  111.       Name_Len := Name_Len + 1;
  112.       Name_Buffer (Name_Len) := '.';
  113.       Name_Len := Name_Len + 1;
  114.       Name_Buffer (Name_Len) := 'a';
  115.       Name_Len := Name_Len + 1;
  116.       Name_Buffer (Name_Len) := 'd';
  117.       Name_Len := Name_Len + 1;
  118.       Name_Buffer (Name_Len) := Unit_Char;
  119.  
  120.       return File_Name_Type (Name_Find);
  121.    end Get_File_Name;
  122.  
  123.    ------------------------------
  124.    -- Is_Language_Defined_Unit --
  125.    ------------------------------
  126.  
  127.    function Is_Language_Defined_Unit (Fname : File_Name_Type) return Boolean is
  128.       subtype Str8 is String (1 .. 8);
  129.  
  130.       Predef_Names : array (1 .. 12) of Str8 :=
  131.          ("ada     ",       -- Ada
  132.           "calendar",       -- Calendar
  133.           "direc_io",       -- Direct_IO
  134.           "gnat    ",       -- GNAT
  135.           "interfac",       -- Interfaces
  136.           "ioexcept",       -- IO_Exceptions
  137.           "machcode",       -- Machine_Code
  138.           "sequenio",       -- Sequential_IO
  139.           "system  ",       -- System
  140.           "text_io ",       -- Text_IO
  141.           "unchconv",       -- Unchecked_Conversion
  142.           "unchdeal");      -- Unchecked_Deallocation
  143.  
  144.    begin
  145.       --  Get file name, removing the extension (if any)
  146.  
  147.       Get_Name_String (Fname);
  148.  
  149.       if Name_Len > 4 and then Name_Buffer (Name_Len - 3) = '.' then
  150.          Name_Len := Name_Len - 4;
  151.       end if;
  152.  
  153.       --  Definitely false if longer than 8 characters
  154.  
  155.       if Name_Len > 8 then
  156.          return False;
  157.       end if;
  158.  
  159.       --  Definitely predefined if prefix is a- g- i- or s-
  160.  
  161.       if Name_Len > 2
  162.         and then Name_Buffer (2) = '-'
  163.         and then (Name_Buffer (1) = 'a' or else
  164.                   Name_Buffer (1) = 'g' or else
  165.                   Name_Buffer (1) = 'i' or else
  166.                   Name_Buffer (1) = 's')
  167.       then
  168.          return True;
  169.       end if;
  170.  
  171.       --  Otherwise check against special list, first padding to 8 characters
  172.  
  173.       while Name_Len < 8 loop
  174.          Name_Len := Name_Len + 1;
  175.          Name_Buffer (Name_Len) := ' ';
  176.       end loop;
  177.  
  178.       for J in 1 .. 12 loop
  179.          if Name_Buffer (1 .. 8) = Predef_Names (J) then
  180.             return True;
  181.          end if;
  182.       end loop;
  183.  
  184.       return False;
  185.  
  186.    end Is_Language_Defined_Unit;
  187.  
  188.    ------------------
  189.    -- Is_File_Name --
  190.    ------------------
  191.  
  192.    function Is_File_Name (Name : Name_Id) return Boolean is
  193.    begin
  194.       Get_Name_String (Name);
  195.       return
  196.         Name_Len > 4
  197.           and then Name_Buffer (Name_Len - 3 .. Name_Len - 1) = ".ad"
  198.           and then (Name_Buffer (Name_Len) = 'b'
  199.                       or else Name_Buffer (Name_Len) = 's');
  200.    end Is_File_Name;
  201.  
  202.    -----------------------
  203.    -- File_Name_Of_Spec --
  204.    -----------------------
  205.  
  206.    function File_Name_Of_Spec (Name : Name_Id) return File_Name_Type is
  207.    begin
  208.       Get_Name_String (Name);
  209.       Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%s";
  210.       Name_Len := Name_Len + 2;
  211.       return Get_File_Name (Name_Enter);
  212.    end File_Name_Of_Spec;
  213.  
  214.    -----------------------
  215.    -- File_Name_Of_Body --
  216.    -----------------------
  217.  
  218.    function File_Name_Of_Body (Name : Name_Id) return File_Name_Type is
  219.    begin
  220.       Get_Name_String (Name);
  221.       Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%b";
  222.       Name_Len := Name_Len + 2;
  223.       return Get_File_Name (Name_Enter);
  224.    end File_Name_Of_Body;
  225.  
  226. end Fname;
  227.