Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/xsinfo.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 ------------------------------------------------------------------------------ | |
2 -- -- | |
3 -- GNAT SYSTEM UTILITIES -- | |
4 -- -- | |
5 -- X S I N F O -- | |
6 -- -- | |
7 -- B o d y -- | |
8 -- -- | |
9 -- Copyright (C) 1992-2011, 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 | |
26 -- Program to construct C header file sinfo.h (C version of sinfo.ads spec, | |
27 -- for use by Gigi, contains all definitions and access functions, but does | |
28 -- not contain set procedures, since Gigi never modifies the GNAT tree) | |
29 | |
30 -- Input files: | |
31 | |
32 -- sinfo.ads Spec of Sinfo package | |
33 | |
34 -- Output files: | |
35 | |
36 -- sinfo.h Corresponding c header file | |
37 | |
38 -- An optional argument allows the specification of an output file name to | |
39 -- override the default sinfo.h file name for the generated output file. | |
40 | |
41 with Ada.Command_Line; use Ada.Command_Line; | |
42 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; | |
43 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; | |
44 with Ada.Text_IO; use Ada.Text_IO; | |
45 | |
46 with GNAT.Spitbol; use GNAT.Spitbol; | |
47 with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; | |
48 | |
49 with CSinfo; | |
50 | |
51 procedure XSinfo is | |
52 | |
53 Done : exception; | |
54 Err : exception; | |
55 | |
56 A : VString := Nul; | |
57 Arg : VString := Nul; | |
58 Comment : VString := Nul; | |
59 Line : VString := Nul; | |
60 N : VString := Nul; | |
61 N1, N2 : VString := Nul; | |
62 Nam : VString := Nul; | |
63 Rtn : VString := Nul; | |
64 Term : VString := Nul; | |
65 | |
66 InS : File_Type; | |
67 Ofile : File_Type; | |
68 | |
69 wsp : constant Pattern := Span (' ' & ASCII.HT); | |
70 Wsp_For : constant Pattern := wsp & "for"; | |
71 Is_Cmnt : constant Pattern := wsp & "--"; | |
72 Typ_Nod : constant Pattern := wsp * A & "type Node_Kind is"; | |
73 Get_Nam : constant Pattern := wsp * A & "N_" & Break (",)") * Nam | |
74 & Len (1) * Term; | |
75 Sub_Typ : constant Pattern := wsp * A & "subtype " & Break (' ') * N; | |
76 No_Cont : constant Pattern := wsp & Break (' ') * N1 | |
77 & " .. " & Break (';') * N2; | |
78 Cont_N1 : constant Pattern := wsp & Break (' ') * N1 & " .." & Rpos (0); | |
79 Cont_N2 : constant Pattern := Span (' ') & Break (';') * N2; | |
80 Is_Func : constant Pattern := wsp * A & "function " & Rest * Nam; | |
81 Get_Arg : constant Pattern := wsp & "(N : " & Break (')') * Arg | |
82 & ") return " & Break (';') * Rtn | |
83 & ';' & wsp & "--" & wsp & Rest * Comment; | |
84 | |
85 NKV : Natural; | |
86 | |
87 M : Match_Result; | |
88 | |
89 procedure Getline; | |
90 -- Get non-comment, non-blank line. Also skips "for " rep clauses | |
91 | |
92 ------------- | |
93 -- Getline -- | |
94 ------------- | |
95 | |
96 procedure Getline is | |
97 begin | |
98 loop | |
99 Line := Get_Line (InS); | |
100 | |
101 if Line /= "" | |
102 and then not Match (Line, Wsp_For) | |
103 and then not Match (Line, Is_Cmnt) | |
104 then | |
105 return; | |
106 | |
107 elsif Match (Line, " -- End functions (note") then | |
108 raise Done; | |
109 end if; | |
110 end loop; | |
111 end Getline; | |
112 | |
113 -- Start of processing for XSinfo | |
114 | |
115 begin | |
116 -- First run CSinfo to check for errors. Note that CSinfo is also a | |
117 -- stand-alone program that can be run separately. | |
118 | |
119 CSinfo; | |
120 | |
121 Set_Exit_Status (1); | |
122 Anchored_Mode := True; | |
123 | |
124 if Argument_Count > 0 then | |
125 Create (Ofile, Out_File, Argument (1)); | |
126 else | |
127 Create (Ofile, Out_File, "sinfo.h"); | |
128 end if; | |
129 | |
130 Open (InS, In_File, "sinfo.ads"); | |
131 | |
132 -- Write header to output file | |
133 | |
134 loop | |
135 Line := Get_Line (InS); | |
136 exit when Line = ""; | |
137 | |
138 Match | |
139 (Line, | |
140 "-- S p e c ", | |
141 "-- C Header File "); | |
142 | |
143 Match (Line, "--", "/*"); | |
144 Match (Line, Rtab (2) * A & "--", M); | |
145 Replace (M, A & "*/"); | |
146 Put_Line (Ofile, Line); | |
147 end loop; | |
148 | |
149 -- Skip to package line | |
150 | |
151 loop | |
152 Getline; | |
153 exit when Match (Line, "package"); | |
154 end loop; | |
155 | |
156 -- Skip to first node kind line | |
157 | |
158 loop | |
159 Getline; | |
160 exit when Match (Line, Typ_Nod); | |
161 Put_Line (Ofile, Line); | |
162 end loop; | |
163 | |
164 Put_Line (Ofile, ""); | |
165 | |
166 Put_Line (Ofile, "#ifdef __cplusplus"); | |
167 Put_Line (Ofile, "extern ""C"" {"); | |
168 Put_Line (Ofile, "#endif"); | |
169 | |
170 NKV := 0; | |
171 | |
172 -- Loop through node kind codes | |
173 | |
174 loop | |
175 Getline; | |
176 | |
177 if Match (Line, Get_Nam) then | |
178 Put_Line (Ofile, A & "#define N_" & Nam & ' ' & NKV); | |
179 NKV := NKV + 1; | |
180 exit when not Match (Term, ","); | |
181 | |
182 else | |
183 Put_Line (Ofile, Line); | |
184 end if; | |
185 end loop; | |
186 | |
187 Put_Line (Ofile, ""); | |
188 Put_Line (Ofile, A & "#define Number_Node_Kinds " & NKV); | |
189 | |
190 -- Loop through subtype declarations | |
191 | |
192 loop | |
193 Getline; | |
194 | |
195 if not Match (Line, Sub_Typ) then | |
196 exit when Match (Line, " function"); | |
197 Put_Line (Ofile, Line); | |
198 | |
199 else | |
200 Put_Line (Ofile, A & "SUBTYPE (" & N & ", Node_Kind, "); | |
201 Getline; | |
202 | |
203 -- Normal case | |
204 | |
205 if Match (Line, No_Cont) then | |
206 Put_Line (Ofile, A & " " & N1 & ", " & N2 & ')'); | |
207 | |
208 -- Continuation case | |
209 | |
210 else | |
211 if not Match (Line, Cont_N1) then | |
212 raise Err; | |
213 end if; | |
214 | |
215 Getline; | |
216 | |
217 if not Match (Line, Cont_N2) then | |
218 raise Err; | |
219 end if; | |
220 | |
221 Put_Line (Ofile, A & " " & N1 & ','); | |
222 Put_Line (Ofile, A & " " & N2 & ')'); | |
223 end if; | |
224 end if; | |
225 end loop; | |
226 | |
227 -- Loop through functions. Note that this loop is terminated by | |
228 -- the call to Getfile encountering the end of functions sentinel | |
229 | |
230 loop | |
231 if Match (Line, Is_Func) then | |
232 Getline; | |
233 if not Match (Line, Get_Arg) then | |
234 raise Err; | |
235 end if; | |
236 Put_Line | |
237 (Ofile, | |
238 A & "INLINE " & Rpad (Rtn, 9) | |
239 & ' ' & Rpad (Nam, 30) & " (" & Arg & " N)"); | |
240 | |
241 Put_Line (Ofile, A & " { return " & Comment & " (N); }"); | |
242 | |
243 else | |
244 Put_Line (Ofile, Line); | |
245 end if; | |
246 | |
247 Getline; | |
248 end loop; | |
249 | |
250 -- Can't get here since above loop only left via raise | |
251 | |
252 exception | |
253 when Done => | |
254 Close (InS); | |
255 Put_Line (Ofile, ""); | |
256 Put_Line (Ofile, "#ifdef __cplusplus"); | |
257 Put_Line (Ofile, "}"); | |
258 Put_Line (Ofile, "#endif"); | |
259 Close (Ofile); | |
260 Set_Exit_Status (0); | |
261 | |
262 end XSinfo; |