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-2020, 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; 32with System.OS_Lib; use System.OS_Lib; 33 34with Unchecked_Conversion; 35 36package body Fname.SF is 37 38 ---------------------- 39 -- Local Procedures -- 40 ---------------------- 41 42 procedure Set_File_Name 43 (Typ : Character; 44 U : String; 45 F : String; 46 Index : Natural); 47 -- This is a transfer function that is called from Scan_SFN_Pragmas, 48 -- and reformats its parameters appropriately for the version of 49 -- Set_File_Name found in Fname.SF. 50 51 procedure Set_File_Name_Pattern 52 (Pat : String; 53 Typ : Character; 54 Dot : String; 55 Cas : Character); 56 -- This is a transfer function that is called from Scan_SFN_Pragmas, 57 -- and reformats its parameters appropriately for the version of 58 -- Set_File_Name_Pattern found in Fname.SF. 59 60 ----------------------------------- 61 -- Read_Source_File_Name_Pragmas -- 62 ----------------------------------- 63 64 procedure Read_Source_File_Name_Pragmas is 65 FD : File_Descriptor; 66 Src : Source_Buffer_Ptr; 67 Hi : Source_Ptr; 68 69 begin 70 Read_Source_File (Name_Enter ("gnat.adc"), 1, Hi, Src, FD); 71 72 if not Null_Source_Buffer_Ptr (Src) then 73 -- We need to strip off the trailing EOF that was added by 74 -- Read_Source_File, because there might be another EOF in 75 -- the file, and two in a row causes Scan_SFN_Pragmas to give 76 -- errors. 77 78 pragma Assert (Src (Hi) = EOF); 79 Scan_SFN_Pragmas 80 (String (Src (1 .. Hi - 1)), 81 Set_File_Name'Access, 82 Set_File_Name_Pattern'Access); 83 end if; 84 end Read_Source_File_Name_Pragmas; 85 86 ------------------- 87 -- Set_File_Name -- 88 ------------------- 89 90 procedure Set_File_Name 91 (Typ : Character; 92 U : String; 93 F : String; 94 Index : Natural) 95 is 96 Unm : Unit_Name_Type; 97 Fnm : File_Name_Type; 98 begin 99 Name_Buffer (1 .. U'Length) := U; 100 Name_Len := U'Length; 101 Set_Casing (All_Lower_Case); 102 Name_Buffer (Name_Len + 1) := '%'; 103 Name_Buffer (Name_Len + 2) := Typ; 104 Name_Len := Name_Len + 2; 105 Unm := Name_Find; 106 Name_Buffer (1 .. F'Length) := F; 107 Name_Len := F'Length; 108 Fnm := Name_Find; 109 Fname.UF.Set_File_Name (Unm, Fnm, Nat (Index)); 110 end Set_File_Name; 111 112 --------------------------- 113 -- Set_File_Name_Pattern -- 114 --------------------------- 115 116 procedure Set_File_Name_Pattern 117 (Pat : String; 118 Typ : Character; 119 Dot : String; 120 Cas : Character) 121 is 122 Ctyp : Casing_Type; 123 Patp : constant String_Ptr := new String'(Pat); 124 Dotp : constant String_Ptr := new String'(Dot); 125 126 begin 127 if Cas = 'l' then 128 Ctyp := All_Lower_Case; 129 elsif Cas = 'u' then 130 Ctyp := All_Upper_Case; 131 else -- Cas = 'm' 132 Ctyp := Mixed_Case; 133 end if; 134 135 Fname.UF.Set_File_Name_Pattern (Patp, Typ, Dotp, Ctyp); 136 end Set_File_Name_Pattern; 137 138end Fname.SF; 139