|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT SYSTEM UTILITIES --
|
|
|
4 -- --
|
|
|
5 -- X N M A K E --
|
|
|
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 -- Program to construct the spec and body of the Nmake package
|
|
|
27
|
|
|
28 -- Input files:
|
|
|
29
|
|
|
30 -- sinfo.ads Spec of Sinfo package
|
|
|
31 -- nmake.adt Template for Nmake package
|
|
|
32
|
|
|
33 -- Output files:
|
|
|
34
|
|
|
35 -- nmake.ads Spec of Nmake package
|
|
|
36 -- nmake.adb Body of Nmake package
|
|
|
37
|
|
|
38 -- Note: this program assumes that sinfo.ads has passed the error checks that
|
|
|
39 -- are carried out by the csinfo utility, so it does not duplicate these
|
|
|
40 -- checks and assumes that sinfo.ads has the correct form.
|
|
|
41
|
|
|
42 -- In the absence of any switches, both the ads and adb files are output.
|
|
|
43 -- The switch -s or /s indicates that only the ads file is to be output.
|
|
|
44 -- The switch -b or /b indicates that only the adb file is to be output.
|
|
|
45
|
|
|
46 -- If a file name argument is given, then the output is written to this file
|
|
|
47 -- rather than to nmake.ads or nmake.adb. A file name can only be given if
|
|
|
48 -- exactly one of the -s or -b options is present.
|
|
|
49
|
|
|
50 with Ada.Command_Line; use Ada.Command_Line;
|
|
|
51 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
|
|
|
52 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
|
|
|
53 with Ada.Strings.Maps; use Ada.Strings.Maps;
|
|
|
54 with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
|
|
|
55 with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
|
|
|
56 with Ada.Text_IO; use Ada.Text_IO;
|
|
|
57
|
|
|
58 with GNAT.Spitbol; use GNAT.Spitbol;
|
|
|
59 with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
|
|
|
60
|
|
|
61 with XUtil;
|
|
|
62
|
|
|
63 procedure XNmake is
|
|
|
64
|
|
|
65 Err : exception;
|
|
|
66 -- Raised to terminate execution
|
|
|
67
|
|
|
68 A : VString := Nul;
|
|
|
69 Arg : VString := Nul;
|
|
|
70 Arg_List : VString := Nul;
|
|
|
71 Comment : VString := Nul;
|
|
|
72 Default : VString := Nul;
|
|
|
73 Field : VString := Nul;
|
|
|
74 Line : VString := Nul;
|
|
|
75 Node : VString := Nul;
|
|
|
76 Op_Name : VString := Nul;
|
|
|
77 Prevl : VString := Nul;
|
|
|
78 Synonym : VString := Nul;
|
|
|
79 X : VString := Nul;
|
|
|
80
|
|
|
81 NWidth : Natural;
|
|
|
82
|
|
|
83 FileS : VString := V ("nmake.ads");
|
|
|
84 FileB : VString := V ("nmake.adb");
|
|
|
85 -- Set to null if corresponding file not to be generated
|
|
|
86
|
|
|
87 Given_File : VString := Nul;
|
|
|
88 -- File name given by command line argument
|
|
|
89
|
|
|
90 subtype Sfile is Ada.Streams.Stream_IO.File_Type;
|
|
|
91
|
|
|
92 InS, InT : Ada.Text_IO.File_Type;
|
|
|
93 OutS, OutB : Sfile;
|
|
|
94
|
|
|
95 wsp : constant Pattern := Span (' ' & ASCII.HT);
|
|
|
96
|
|
|
97 Body_Only : constant Pattern := BreakX (' ') * X
|
|
|
98 & Span (' ') & "-- body only";
|
|
|
99 Spec_Only : constant Pattern := BreakX (' ') * X
|
|
|
100 & Span (' ') & "-- spec only";
|
|
|
101
|
|
|
102 Node_Hdr : constant Pattern := wsp & "-- N_" & Rest * Node;
|
|
|
103 Punc : constant Pattern := BreakX (" .,");
|
|
|
104
|
|
|
105 Binop : constant Pattern := wsp
|
|
|
106 & "-- plus fields for binary operator";
|
|
|
107 Unop : constant Pattern := wsp
|
|
|
108 & "-- plus fields for unary operator";
|
|
|
109 Syn : constant Pattern := wsp & "-- " & Break (' ') * Synonym
|
|
|
110 & " (" & Break (')') * Field
|
|
|
111 & Rest * Comment;
|
|
|
112
|
|
|
113 Templ : constant Pattern := BreakX ('T') * A & "T e m p l a t e";
|
|
|
114 Spec : constant Pattern := BreakX ('S') * A & "S p e c";
|
|
|
115
|
|
|
116 Sem_Field : constant Pattern := BreakX ('-') & "-Sem";
|
|
|
117 Lib_Field : constant Pattern := BreakX ('-') & "-Lib";
|
|
|
118
|
|
|
119 Get_Field : constant Pattern := BreakX (Decimal_Digit_Set) * Field;
|
|
|
120
|
|
|
121 Get_Dflt : constant Pattern := BreakX ('(') & "(set to "
|
|
|
122 & Break (" ") * Default & " if";
|
|
|
123
|
|
|
124 Next_Arg : constant Pattern := Break (',') * Arg & ',';
|
|
|
125
|
|
|
126 Op_Node : constant Pattern := "Op_" & Rest * Op_Name;
|
|
|
127
|
|
|
128 Shft_Rot : constant Pattern := "Shift_" or "Rotate_";
|
|
|
129
|
|
|
130 No_Ent : constant Pattern := "Or_Else" or "And_Then"
|
|
|
131 or "In" or "Not_In";
|
|
|
132
|
|
|
133 M : Match_Result;
|
|
|
134
|
|
|
135 V_String_Id : constant VString := V ("String_Id");
|
|
|
136 V_Node_Id : constant VString := V ("Node_Id");
|
|
|
137 V_Name_Id : constant VString := V ("Name_Id");
|
|
|
138 V_List_Id : constant VString := V ("List_Id");
|
|
|
139 V_Elist_Id : constant VString := V ("Elist_Id");
|
|
|
140 V_Boolean : constant VString := V ("Boolean");
|
|
|
141
|
|
|
142 procedure Put_Line (F : Sfile; S : String) renames XUtil.Put_Line;
|
|
|
143 procedure Put_Line (F : Sfile; S : VString) renames XUtil.Put_Line;
|
|
|
144 -- Local version of Put_Line ensures Unix style line endings
|
|
|
145
|
|
|
146 procedure WriteS (S : String);
|
|
|
147 procedure WriteB (S : String);
|
|
|
148 procedure WriteBS (S : String);
|
|
|
149 procedure WriteS (S : VString);
|
|
|
150 procedure WriteB (S : VString);
|
|
|
151 procedure WriteBS (S : VString);
|
|
|
152 -- Write given line to spec or body file or both if active
|
|
|
153
|
|
|
154 procedure WriteB (S : String) is
|
|
|
155 begin
|
|
|
156 if FileB /= Nul then
|
|
|
157 Put_Line (OutB, S);
|
|
|
158 end if;
|
|
|
159 end WriteB;
|
|
|
160
|
|
|
161 procedure WriteB (S : VString) is
|
|
|
162 begin
|
|
|
163 if FileB /= Nul then
|
|
|
164 Put_Line (OutB, S);
|
|
|
165 end if;
|
|
|
166 end WriteB;
|
|
|
167
|
|
|
168 procedure WriteBS (S : String) is
|
|
|
169 begin
|
|
|
170 if FileB /= Nul then
|
|
|
171 Put_Line (OutB, S);
|
|
|
172 end if;
|
|
|
173
|
|
|
174 if FileS /= Nul then
|
|
|
175 Put_Line (OutS, S);
|
|
|
176 end if;
|
|
|
177 end WriteBS;
|
|
|
178
|
|
|
179 procedure WriteBS (S : VString) is
|
|
|
180 begin
|
|
|
181 if FileB /= Nul then
|
|
|
182 Put_Line (OutB, S);
|
|
|
183 end if;
|
|
|
184
|
|
|
185 if FileS /= Nul then
|
|
|
186 Put_Line (OutS, S);
|
|
|
187 end if;
|
|
|
188 end WriteBS;
|
|
|
189
|
|
|
190 procedure WriteS (S : String) is
|
|
|
191 begin
|
|
|
192 if FileS /= Nul then
|
|
|
193 Put_Line (OutS, S);
|
|
|
194 end if;
|
|
|
195 end WriteS;
|
|
|
196
|
|
|
197 procedure WriteS (S : VString) is
|
|
|
198 begin
|
|
|
199 if FileS /= Nul then
|
|
|
200 Put_Line (OutS, S);
|
|
|
201 end if;
|
|
|
202 end WriteS;
|
|
|
203
|
|
|
204 -- Start of processing for XNmake
|
|
|
205
|
|
|
206 begin
|
|
|
207 NWidth := 28;
|
|
|
208 Anchored_Mode := True;
|
|
|
209
|
|
|
210 for ArgN in 1 .. Argument_Count loop
|
|
|
211 declare
|
|
|
212 Arg : constant String := Argument (ArgN);
|
|
|
213
|
|
|
214 begin
|
|
|
215 if Arg (1) = '-' then
|
|
|
216 if Arg'Length = 2
|
|
|
217 and then (Arg (2) = 'b' or else Arg (2) = 'B')
|
|
|
218 then
|
|
|
219 FileS := Nul;
|
|
|
220
|
|
|
221 elsif Arg'Length = 2
|
|
|
222 and then (Arg (2) = 's' or else Arg (2) = 'S')
|
|
|
223 then
|
|
|
224 FileB := Nul;
|
|
|
225
|
|
|
226 else
|
|
|
227 raise Err;
|
|
|
228 end if;
|
|
|
229
|
|
|
230 else
|
|
|
231 if Given_File /= Nul then
|
|
|
232 raise Err;
|
|
|
233 else
|
|
|
234 Given_File := V (Arg);
|
|
|
235 end if;
|
|
|
236 end if;
|
|
|
237 end;
|
|
|
238 end loop;
|
|
|
239
|
|
|
240 if FileS = Nul and then FileB = Nul then
|
|
|
241 raise Err;
|
|
|
242
|
|
|
243 elsif Given_File /= Nul then
|
|
|
244 if FileB = Nul then
|
|
|
245 FileS := Given_File;
|
|
|
246
|
|
|
247 elsif FileS = Nul then
|
|
|
248 FileB := Given_File;
|
|
|
249
|
|
|
250 else
|
|
|
251 raise Err;
|
|
|
252 end if;
|
|
|
253 end if;
|
|
|
254
|
|
|
255 Open (InS, In_File, "sinfo.ads");
|
|
|
256 Open (InT, In_File, "nmake.adt");
|
|
|
257
|
|
|
258 if FileS /= Nul then
|
|
|
259 Create (OutS, Out_File, S (FileS));
|
|
|
260 end if;
|
|
|
261
|
|
|
262 if FileB /= Nul then
|
|
|
263 Create (OutB, Out_File, S (FileB));
|
|
|
264 end if;
|
|
|
265
|
|
|
266 Anchored_Mode := True;
|
|
|
267
|
|
|
268 -- Copy initial part of template to spec and body
|
|
|
269
|
|
|
270 loop
|
|
|
271 Line := Get_Line (InT);
|
|
|
272
|
|
|
273 -- Skip lines describing the template
|
|
|
274
|
|
|
275 if Match (Line, "-- This file is a template") then
|
|
|
276 loop
|
|
|
277 Line := Get_Line (InT);
|
|
|
278 exit when Line = "";
|
|
|
279 end loop;
|
|
|
280 end if;
|
|
|
281
|
|
|
282 -- Loop keeps going until "package" keyword written
|
|
|
283
|
|
|
284 exit when Match (Line, "package");
|
|
|
285
|
|
|
286 -- Deal with WITH lines, writing to body or spec as appropriate
|
|
|
287
|
|
|
288 if Match (Line, Body_Only, M) then
|
|
|
289 Replace (M, X);
|
|
|
290 WriteB (Line);
|
|
|
291
|
|
|
292 elsif Match (Line, Spec_Only, M) then
|
|
|
293 Replace (M, X);
|
|
|
294 WriteS (Line);
|
|
|
295
|
|
|
296 -- Change header from Template to Spec and write to spec file
|
|
|
297
|
|
|
298 else
|
|
|
299 if Match (Line, Templ, M) then
|
|
|
300 Replace (M, A & " S p e c ");
|
|
|
301 end if;
|
|
|
302
|
|
|
303 WriteS (Line);
|
|
|
304
|
|
|
305 -- Write header line to body file
|
|
|
306
|
|
|
307 if Match (Line, Spec, M) then
|
|
|
308 Replace (M, A & "B o d y");
|
|
|
309 end if;
|
|
|
310
|
|
|
311 WriteB (Line);
|
|
|
312 end if;
|
|
|
313 end loop;
|
|
|
314
|
|
|
315 -- Package line reached
|
|
|
316
|
|
|
317 WriteS ("package Nmake is");
|
|
|
318 WriteB ("package body Nmake is");
|
|
|
319 WriteB ("");
|
|
|
320
|
|
|
321 -- Copy rest of lines up to template insert point to spec only
|
|
|
322
|
|
|
323 loop
|
|
|
324 Line := Get_Line (InT);
|
|
|
325 exit when Match (Line, "!!TEMPLATE INSERTION POINT");
|
|
|
326 WriteS (Line);
|
|
|
327 end loop;
|
|
|
328
|
|
|
329 -- Here we are doing the actual insertions, loop through node types
|
|
|
330
|
|
|
331 loop
|
|
|
332 Line := Get_Line (InS);
|
|
|
333
|
|
|
334 if Match (Line, Node_Hdr)
|
|
|
335 and then not Match (Node, Punc)
|
|
|
336 and then Node /= "Unused"
|
|
|
337 then
|
|
|
338 exit when Node = "Empty";
|
|
|
339 Prevl := " function Make_" & Node & " (Sloc : Source_Ptr";
|
|
|
340 Arg_List := Nul;
|
|
|
341
|
|
|
342 -- Loop through fields of one node
|
|
|
343
|
|
|
344 loop
|
|
|
345 Line := Get_Line (InS);
|
|
|
346 exit when Line = "";
|
|
|
347
|
|
|
348 if Match (Line, Binop) then
|
|
|
349 WriteBS (Prevl & ';');
|
|
|
350 Append (Arg_List, "Left_Opnd,Right_Opnd,");
|
|
|
351 WriteBS (
|
|
|
352 " " & Rpad ("Left_Opnd", NWidth) & " : Node_Id;");
|
|
|
353 Prevl :=
|
|
|
354 " " & Rpad ("Right_Opnd", NWidth) & " : Node_Id";
|
|
|
355
|
|
|
356 elsif Match (Line, Unop) then
|
|
|
357 WriteBS (Prevl & ';');
|
|
|
358 Append (Arg_List, "Right_Opnd,");
|
|
|
359 Prevl := " " & Rpad ("Right_Opnd", NWidth) & " : Node_Id";
|
|
|
360
|
|
|
361 elsif Match (Line, Syn) then
|
|
|
362 if Synonym /= "Prev_Ids"
|
|
|
363 and then Synonym /= "More_Ids"
|
|
|
364 and then Synonym /= "Comes_From_Source"
|
|
|
365 and then Synonym /= "Paren_Count"
|
|
|
366 and then not Match (Field, Sem_Field)
|
|
|
367 and then not Match (Field, Lib_Field)
|
|
|
368 then
|
|
|
369 Match (Field, Get_Field);
|
|
|
370
|
|
|
371 if Field = "Str" then
|
|
|
372 Field := V_String_Id;
|
|
|
373 elsif Field = "Node" then
|
|
|
374 Field := V_Node_Id;
|
|
|
375 elsif Field = "Name" then
|
|
|
376 Field := V_Name_Id;
|
|
|
377 elsif Field = "List" then
|
|
|
378 Field := V_List_Id;
|
|
|
379 elsif Field = "Elist" then
|
|
|
380 Field := V_Elist_Id;
|
|
|
381 elsif Field = "Flag" then
|
|
|
382 Field := V_Boolean;
|
|
|
383 end if;
|
|
|
384
|
|
|
385 if Field = "Boolean" then
|
|
|
386 Default := V ("False");
|
|
|
387 else
|
|
|
388 Default := Nul;
|
|
|
389 end if;
|
|
|
390
|
|
|
391 Match (Comment, Get_Dflt);
|
|
|
392
|
|
|
393 WriteBS (Prevl & ';');
|
|
|
394 Append (Arg_List, Synonym & ',');
|
|
|
395 Rpad (Synonym, NWidth);
|
|
|
396
|
|
|
397 if Default = "" then
|
|
|
398 Prevl := " " & Synonym & " : " & Field;
|
|
|
399 else
|
|
|
400 Prevl :=
|
|
|
401 " " & Synonym & " : " & Field & " := " & Default;
|
|
|
402 end if;
|
|
|
403 end if;
|
|
|
404 end if;
|
|
|
405 end loop;
|
|
|
406
|
|
|
407 WriteBS (Prevl & ')');
|
|
|
408 WriteS (" return Node_Id;");
|
|
|
409 WriteS (" pragma Inline (Make_" & Node & ");");
|
|
|
410 WriteB (" return Node_Id");
|
|
|
411 WriteB (" is");
|
|
|
412 WriteB (" N : constant Node_Id :=");
|
|
|
413
|
|
|
414 if Match (Node, "Defining_Identifier") or else
|
|
|
415 Match (Node, "Defining_Character") or else
|
|
|
416 Match (Node, "Defining_Operator")
|
|
|
417 then
|
|
|
418 WriteB (" New_Entity (N_" & Node & ", Sloc);");
|
|
|
419 else
|
|
|
420 WriteB (" New_Node (N_" & Node & ", Sloc);");
|
|
|
421 end if;
|
|
|
422
|
|
|
423 WriteB (" begin");
|
|
|
424
|
|
|
425 while Match (Arg_List, Next_Arg, "") loop
|
|
|
426 if Length (Arg) < NWidth then
|
|
|
427 WriteB (" Set_" & Arg & " (N, " & Arg & ");");
|
|
|
428 else
|
|
|
429 WriteB (" Set_" & Arg);
|
|
|
430 WriteB (" (N, " & Arg & ");");
|
|
|
431 end if;
|
|
|
432 end loop;
|
|
|
433
|
|
|
434 if Match (Node, Op_Node) then
|
|
|
435 if Node = "Op_Plus" then
|
|
|
436 WriteB (" Set_Chars (N, Name_Op_Add);");
|
|
|
437
|
|
|
438 elsif Node = "Op_Minus" then
|
|
|
439 WriteB (" Set_Chars (N, Name_Op_Subtract);");
|
|
|
440
|
|
|
441 elsif Match (Op_Name, Shft_Rot) then
|
|
|
442 WriteB (" Set_Chars (N, Name_" & Op_Name & ");");
|
|
|
443
|
|
|
444 else
|
|
|
445 WriteB (" Set_Chars (N, Name_" & Node & ");");
|
|
|
446 end if;
|
|
|
447
|
|
|
448 if not Match (Op_Name, No_Ent) then
|
|
|
449 WriteB (" Set_Entity (N, Standard_" & Node & ");");
|
|
|
450 end if;
|
|
|
451 end if;
|
|
|
452
|
|
|
453 WriteB (" return N;");
|
|
|
454 WriteB (" end Make_" & Node & ';');
|
|
|
455 WriteBS ("");
|
|
|
456 end if;
|
|
|
457 end loop;
|
|
|
458
|
|
|
459 WriteBS ("end Nmake;");
|
|
|
460
|
|
|
461 exception
|
|
|
462
|
|
|
463 when Err =>
|
|
|
464 Put_Line (Standard_Error, "usage: xnmake [-b] [-s] [filename]");
|
|
|
465 Set_Exit_Status (1);
|
|
|
466
|
|
|
467 end XNmake;
|
