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-2019, 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