111
|
1 ------------------------------------------------------------------------------
|
|
2 -- --
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
4 -- --
|
|
5 -- F N A M E . S F --
|
|
6 -- --
|
|
7 -- B o d y --
|
|
8 -- --
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
111
|
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
|
|
26 with Casing; use Casing;
|
|
27 with Fname; use Fname;
|
|
28 with Fname.UF; use Fname.UF;
|
|
29 with SFN_Scan; use SFN_Scan;
|
|
30 with Osint; use Osint;
|
|
31 with Types; use Types;
|
|
32 with System.OS_Lib; use System.OS_Lib;
|
|
33
|
|
34 with Unchecked_Conversion;
|
|
35
|
|
36 package 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
|
|
138 end Fname.SF;
|