File : xnmake.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT SYSTEM UTILITIES --
4 -- --
5 -- X N M A K E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2008, 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 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;