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
50with Ada.Command_Line;              use Ada.Command_Line;
51with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
52with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
53with Ada.Strings.Maps;              use Ada.Strings.Maps;
54with Ada.Strings.Maps.Constants;    use Ada.Strings.Maps.Constants;
55with Ada.Streams.Stream_IO;         use Ada.Streams.Stream_IO;
56with Ada.Text_IO;                   use Ada.Text_IO;
57
58with GNAT.Spitbol;                  use GNAT.Spitbol;
59with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
60
61with XUtil;
62
63procedure 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
206begin
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
461exception
462
463   when Err =>
464      Put_Line (Standard_Error, "usage: xnmake [-b] [-s] [filename]");
465      Set_Exit_Status (1);
466
467end XNmake;
468