1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- F N A M E . S F -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Casing; use Casing; 27with Fname; use Fname; 28with Fname.UF; use Fname.UF; 29with SFN_Scan; use SFN_Scan; 30with Osint; use Osint; 31with Types; use Types; 32 33with Unchecked_Conversion; 34 35package body Fname.SF is 36 37 function To_Big_String_Ptr is new Unchecked_Conversion 38 (Source_Buffer_Ptr, Big_String_Ptr); 39 40 ---------------------- 41 -- Local Procedures -- 42 ---------------------- 43 44 procedure Set_File_Name 45 (Typ : Character; 46 U : String; 47 F : String; 48 Index : Natural); 49 -- This is a transfer function that is called from Scan_SFN_Pragmas, 50 -- and reformats its parameters appropriately for the version of 51 -- Set_File_Name found in Fname.SF. 52 53 procedure Set_File_Name_Pattern 54 (Pat : String; 55 Typ : Character; 56 Dot : String; 57 Cas : Character); 58 -- This is a transfer function that is called from Scan_SFN_Pragmas, 59 -- and reformats its parameters appropriately for the version of 60 -- Set_File_Name_Pattern found in Fname.SF. 61 62 ----------------------------------- 63 -- Read_Source_File_Name_Pragmas -- 64 ----------------------------------- 65 66 procedure Read_Source_File_Name_Pragmas is 67 Src : Source_Buffer_Ptr; 68 Hi : Source_Ptr; 69 BS : Big_String_Ptr; 70 SP : String_Ptr; 71 72 begin 73 Name_Buffer (1 .. 8) := "gnat.adc"; 74 Name_Len := 8; 75 Read_Source_File (Name_Enter, 0, Hi, Src); 76 77 if Src /= null then 78 BS := To_Big_String_Ptr (Src); 79 SP := BS (1 .. Natural (Hi))'Unrestricted_Access; 80 Scan_SFN_Pragmas 81 (SP.all, 82 Set_File_Name'Access, 83 Set_File_Name_Pattern'Access); 84 end if; 85 end Read_Source_File_Name_Pragmas; 86 87 ------------------- 88 -- Set_File_Name -- 89 ------------------- 90 91 procedure Set_File_Name 92 (Typ : Character; 93 U : String; 94 F : String; 95 Index : Natural) 96 is 97 Unm : Unit_Name_Type; 98 Fnm : File_Name_Type; 99 begin 100 Name_Buffer (1 .. U'Length) := U; 101 Name_Len := U'Length; 102 Set_Casing (All_Lower_Case); 103 Name_Buffer (Name_Len + 1) := '%'; 104 Name_Buffer (Name_Len + 2) := Typ; 105 Name_Len := Name_Len + 2; 106 Unm := Name_Find; 107 Name_Buffer (1 .. F'Length) := F; 108 Name_Len := F'Length; 109 Fnm := Name_Find; 110 Fname.UF.Set_File_Name (Unm, Fnm, Nat (Index)); 111 end Set_File_Name; 112 113 --------------------------- 114 -- Set_File_Name_Pattern -- 115 --------------------------- 116 117 procedure Set_File_Name_Pattern 118 (Pat : String; 119 Typ : Character; 120 Dot : String; 121 Cas : Character) 122 is 123 Ctyp : Casing_Type; 124 Patp : constant String_Ptr := new String'(Pat); 125 Dotp : constant String_Ptr := new String'(Dot); 126 127 begin 128 if Cas = 'l' then 129 Ctyp := All_Lower_Case; 130 elsif Cas = 'u' then 131 Ctyp := All_Upper_Case; 132 else -- Cas = 'm' 133 Ctyp := Mixed_Case; 134 end if; 135 136 Fname.UF.Set_File_Name_Pattern (Patp, Typ, Dotp, Ctyp); 137 end Set_File_Name_Pattern; 138 139end Fname.SF; 140