diff options
Diffstat (limited to 'gcc/ada/fname-sf.adb')
| -rw-r--r-- | gcc/ada/fname-sf.adb | 138 |
1 files changed, 138 insertions, 0 deletions
diff --git a/gcc/ada/fname-sf.adb b/gcc/ada/fname-sf.adb new file mode 100644 index 00000000000..ddb0134ca73 --- /dev/null +++ b/gcc/ada/fname-sf.adb @@ -0,0 +1,138 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F N A M E . S F -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.1 $ +-- -- +-- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Casing; use Casing; +with Fname; use Fname; +with Fname.UF; use Fname.UF; +with SFN_Scan; use SFN_Scan; +with Namet; use Namet; +with Osint; use Osint; +with Types; use Types; + +with Unchecked_Conversion; + +package body Fname.SF is + + subtype Big_String is String (Positive); + type Big_String_Ptr is access all Big_String; + + function To_Big_String_Ptr is new Unchecked_Conversion + (Source_Buffer_Ptr, Big_String_Ptr); + + ---------------------- + -- Local Procedures -- + ---------------------- + + procedure Set_File_Name (Typ : Character; U : String; F : String); + -- This is a transfer function that is called from Scan_SFN_Pragmas, + -- and reformats its parameters appropriately for the version of + -- Set_File_Name found in Fname.SF. + + procedure Set_File_Name_Pattern + (Pat : String; + Typ : Character; + Dot : String; + Cas : Character); + -- This is a transfer function that is called from Scan_SFN_Pragmas, + -- and reformats its parameters appropriately for the version of + -- Set_File_Name_Pattern found in Fname.SF. + + ----------------------------------- + -- Read_Source_File_Name_Pragmas -- + ----------------------------------- + + procedure Read_Source_File_Name_Pragmas is + Src : Source_Buffer_Ptr; + Hi : Source_Ptr; + BS : Big_String_Ptr; + SP : String_Ptr; + + begin + Name_Buffer (1 .. 8) := "gnat.adc"; + Name_Len := 8; + Read_Source_File (Name_Enter, 0, Hi, Src); + + if Src /= null then + BS := To_Big_String_Ptr (Src); + SP := BS (1 .. Natural (Hi))'Unrestricted_Access; + Scan_SFN_Pragmas + (SP.all, + Set_File_Name'Access, + Set_File_Name_Pattern'Access); + end if; + end Read_Source_File_Name_Pragmas; + + ------------------- + -- Set_File_Name -- + ------------------- + + procedure Set_File_Name (Typ : Character; U : String; F : String) is + Unm : Unit_Name_Type; + Fnm : File_Name_Type; + + begin + Name_Buffer (1 .. U'Length) := U; + Name_Len := U'Length; + Set_Casing (All_Lower_Case); + Name_Buffer (Name_Len + 1) := '%'; + Name_Buffer (Name_Len + 2) := Typ; + Name_Len := Name_Len + 2; + Unm := Name_Find; + Name_Buffer (1 .. F'Length) := F; + Name_Len := F'Length; + Fnm := Name_Find; + Fname.UF.Set_File_Name (Unm, Fnm); + end Set_File_Name; + + --------------------------- + -- Set_File_Name_Pattern -- + --------------------------- + + procedure Set_File_Name_Pattern + (Pat : String; + Typ : Character; + Dot : String; + Cas : Character) + is + Ctyp : Casing_Type; + Patp : constant String_Ptr := new String'(Pat); + Dotp : constant String_Ptr := new String'(Dot); + + begin + if Cas = 'l' then + Ctyp := All_Lower_Case; + elsif Cas = 'u' then + Ctyp := All_Upper_Case; + else -- Cas = 'm' + Ctyp := Mixed_Case; + end if; + + Fname.UF.Set_File_Name_Pattern (Patp, Typ, Dotp, Ctyp); + end Set_File_Name_Pattern; + +end Fname.SF; |