annotate gcc/ada/fname-sf.adb @ 131:84e7813d76e9

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