1------------------------------------------------------------------------------ 2-- -- 3-- GNAT SYSTEM UTILITIES -- 4-- -- 5-- X O S C O N S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2008-2012, 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-- The base name of the template file is given by Argument (1). This program 27-- generates the spec for this specified unit (let's call it UNIT_NAME). 28 29-- It works in conjunction with a C template file which must be pre-processed 30-- and compiled using the cross compiler. Two input files are used: 31-- - the preprocessed C file: UNIT_NAME-tmplt.i 32-- - the generated assembly file: UNIT_NAME-tmplt.s 33 34-- The generated files are UNIT_NAME.ads and UNIT_NAME.h 35 36with Ada.Characters.Handling; use Ada.Characters.Handling; 37with Ada.Command_Line; use Ada.Command_Line; 38with Ada.Exceptions; use Ada.Exceptions; 39with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; 40with Ada.Strings.Fixed; use Ada.Strings.Fixed; 41with Ada.Strings.Maps; use Ada.Strings.Maps; 42with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; 43with Ada.Text_IO; use Ada.Text_IO; 44 45pragma Warnings (Off); 46-- System.Unsigned_Types is an internal GNAT unit 47with System.Unsigned_Types; use System.Unsigned_Types; 48pragma Warnings (On); 49 50with GNAT.String_Split; use GNAT.String_Split; 51with GNAT.Table; 52 53with XUtil; use XUtil; 54 55procedure XOSCons is 56 57 use Ada.Strings; 58 use ASCII; 59 60 Unit_Name : constant String := Argument (1); 61 Tmpl_Name : constant String := Unit_Name & "-tmplt"; 62 63 ------------------------------------------------- 64 -- Information retrieved from assembly listing -- 65 ------------------------------------------------- 66 67 type String_Access is access all String; 68 -- Note: we can't use GNAT.Strings for this definition, since that unit 69 -- is not available in older base compilers. 70 71 -- We need to deal with integer values that can be signed or unsigned, so 72 -- we need to accommodate the maximum range of both cases. 73 74 type Int_Value_Type is record 75 Positive : Boolean; 76 Abs_Value : Long_Unsigned := 0; 77 end record; 78 79 function ">" (V1, V2 : Int_Value_Type) return Boolean; 80 function "<" (V1, V2 : Int_Value_Type) return Boolean; 81 82 type Asm_Info_Kind is 83 (CND, -- Named number (decimal) 84 CNU, -- Named number (decimal, unsigned) 85 CNS, -- Named number (freeform text) 86 C, -- Constant object 87 SUB, -- Subtype 88 TXT); -- Literal text 89 -- Recognized markers found in assembly file. These markers are produced by 90 -- the same-named macros from the C template. 91 92 subtype Asm_Int_Kind is Asm_Info_Kind range CND .. CNU; 93 -- Asm_Info_Kind values with int values in input 94 95 subtype Named_Number is Asm_Info_Kind range CND .. CNS; 96 -- Asm_Info_Kind values with named numbers in output 97 98 type Asm_Info (Kind : Asm_Info_Kind := TXT) is record 99 Line_Number : Integer; 100 -- Line number in C source file 101 102 Constant_Name : String_Access; 103 -- Name of constant to be defined 104 105 Constant_Type : String_Access; 106 -- Type of constant (case of Kind = C) 107 108 Value_Len : Natural := 0; 109 -- Length of text representation of constant's value 110 111 Text_Value : String_Access; 112 -- Value for CNS / C constant 113 114 Int_Value : Int_Value_Type; 115 -- Value for CND / CNU constant 116 117 Comment : String_Access; 118 -- Additional descriptive comment for constant, or free-form text (TXT) 119 end record; 120 121 package Asm_Infos is new GNAT.Table 122 (Table_Component_Type => Asm_Info, 123 Table_Index_Type => Integer, 124 Table_Low_Bound => 1, 125 Table_Initial => 100, 126 Table_Increment => 10); 127 128 Max_Constant_Name_Len : Natural := 0; 129 Max_Constant_Value_Len : Natural := 0; 130 Max_Constant_Type_Len : Natural := 0; 131 -- Lengths of longest name and longest value 132 133 Size_Of_Unsigned_Int : Integer := 0; 134 -- Size of unsigned int on target 135 136 type Language is (Lang_Ada, Lang_C); 137 138 function Parse_Int (S : String; K : Asm_Int_Kind) return Int_Value_Type; 139 -- Parse a decimal number, preceded by an optional '$' or '#' character, 140 -- and return its value. 141 142 procedure Output_Info 143 (Lang : Language; 144 OFile : Sfile; 145 Info_Index : Integer); 146 -- Output information from the indicated asm info line 147 148 procedure Parse_Asm_Line (Line : String); 149 -- Parse one information line from the assembly source 150 151 function Contains_Template_Name (S : String) return Boolean; 152 -- True if S contains Tmpl_Name, possibly with different casing 153 154 function Spaces (Count : Integer) return String; 155 -- If Count is positive, return a string of Count spaces, else return an 156 -- empty string. 157 158 --------- 159 -- ">" -- 160 --------- 161 162 function ">" (V1, V2 : Int_Value_Type) return Boolean is 163 P1 : Boolean renames V1.Positive; 164 P2 : Boolean renames V2.Positive; 165 A1 : Long_Unsigned renames V1.Abs_Value; 166 A2 : Long_Unsigned renames V2.Abs_Value; 167 begin 168 return (P1 and then not P2) 169 or else (P1 and then P2 and then A1 > A2) 170 or else (not P1 and then not P2 and then A1 < A2); 171 end ">"; 172 173 --------- 174 -- "<" -- 175 --------- 176 177 function "<" (V1, V2 : Int_Value_Type) return Boolean is 178 begin 179 return not (V1 > V2) and then not (V1 = V2); 180 end "<"; 181 182 ---------------------------- 183 -- Contains_Template_Name -- 184 ---------------------------- 185 186 function Contains_Template_Name (S : String) return Boolean is 187 begin 188 if Index (Source => To_Lower (S), Pattern => Tmpl_Name) > 0 then 189 return True; 190 else 191 return False; 192 end if; 193 end Contains_Template_Name; 194 195 ----------------- 196 -- Output_Info -- 197 ----------------- 198 199 procedure Output_Info 200 (Lang : Language; 201 OFile : Sfile; 202 Info_Index : Integer) 203 is 204 Info : Asm_Info renames Asm_Infos.Table (Info_Index); 205 206 procedure Put (S : String); 207 -- Write S to OFile 208 209 --------- 210 -- Put -- 211 --------- 212 213 procedure Put (S : String) is 214 begin 215 Put (OFile, S); 216 end Put; 217 218 -- Start of processing for Output_Info 219 220 begin 221 case Info.Kind is 222 when TXT => 223 224 -- Handled in the common code for comments below 225 226 null; 227 228 when SUB => 229 case Lang is 230 when Lang_Ada => 231 Put (" subtype " & Info.Constant_Name.all 232 & " is Interfaces.C." 233 & Info.Text_Value.all & ";"); 234 when Lang_C => 235 Put ("#define " & Info.Constant_Name.all & " " 236 & Info.Text_Value.all); 237 end case; 238 239 when others => 240 241 -- All named number cases 242 243 case Lang is 244 when Lang_Ada => 245 Put (" " & Info.Constant_Name.all); 246 Put (Spaces (Max_Constant_Name_Len 247 - Info.Constant_Name'Length)); 248 249 if Info.Kind in Named_Number then 250 Put (" : constant := "); 251 else 252 Put (" : constant " & Info.Constant_Type.all); 253 Put (Spaces (Max_Constant_Type_Len 254 - Info.Constant_Type'Length)); 255 Put (" := "); 256 end if; 257 258 when Lang_C => 259 Put ("#define " & Info.Constant_Name.all & " "); 260 Put (Spaces (Max_Constant_Name_Len 261 - Info.Constant_Name'Length)); 262 end case; 263 264 if Info.Kind in Asm_Int_Kind then 265 if not Info.Int_Value.Positive then 266 Put ("-"); 267 end if; 268 269 Put (Trim (Info.Int_Value.Abs_Value'Img, Side => Left)); 270 271 else 272 declare 273 Is_String : constant Boolean := 274 Info.Kind = C 275 and then Info.Constant_Type.all = "String"; 276 277 begin 278 if Is_String then 279 Put (""""); 280 end if; 281 282 Put (Info.Text_Value.all); 283 284 if Is_String then 285 Put (""""); 286 end if; 287 end; 288 end if; 289 290 if Lang = Lang_Ada then 291 Put (";"); 292 293 if Info.Comment'Length > 0 then 294 Put (Spaces (Max_Constant_Value_Len - Info.Value_Len)); 295 Put (" -- "); 296 end if; 297 end if; 298 end case; 299 300 if Lang = Lang_Ada then 301 Put (Info.Comment.all); 302 end if; 303 304 New_Line (OFile); 305 end Output_Info; 306 307 -------------------- 308 -- Parse_Asm_Line -- 309 -------------------- 310 311 procedure Parse_Asm_Line (Line : String) is 312 Index1, Index2 : Integer := Line'First; 313 314 function Field_Alloc return String_Access; 315 -- Allocate and return a copy of Line (Index1 .. Index2 - 1) 316 317 procedure Find_Colon (Index : in out Integer); 318 -- Increment Index until the next colon in Line 319 320 ----------------- 321 -- Field_Alloc -- 322 ----------------- 323 324 function Field_Alloc return String_Access is 325 begin 326 return new String'(Line (Index1 .. Index2 - 1)); 327 end Field_Alloc; 328 329 ---------------- 330 -- Find_Colon -- 331 ---------------- 332 333 procedure Find_Colon (Index : in out Integer) is 334 begin 335 loop 336 Index := Index + 1; 337 exit when Index > Line'Last or else Line (Index) = ':'; 338 end loop; 339 end Find_Colon; 340 341 -- Start of processing for Parse_Asm_Line 342 343 begin 344 Find_Colon (Index2); 345 346 declare 347 Info : Asm_Info (Kind => Asm_Info_Kind'Value 348 (Line (Line'First .. Index2 - 1))); 349 begin 350 Index1 := Index2 + 1; 351 Find_Colon (Index2); 352 353 Info.Line_Number := 354 Integer (Parse_Int (Line (Index1 .. Index2 - 1), CNU).Abs_Value); 355 356 case Info.Kind is 357 when CND | CNU | CNS | C | SUB => 358 Index1 := Index2 + 1; 359 Find_Colon (Index2); 360 361 Info.Constant_Name := Field_Alloc; 362 363 if Info.Kind /= SUB 364 and then 365 Info.Constant_Name'Length > Max_Constant_Name_Len 366 then 367 Max_Constant_Name_Len := Info.Constant_Name'Length; 368 end if; 369 370 Index1 := Index2 + 1; 371 Find_Colon (Index2); 372 373 if Info.Kind = C then 374 Info.Constant_Type := Field_Alloc; 375 376 if Info.Constant_Type'Length > Max_Constant_Type_Len then 377 Max_Constant_Type_Len := Info.Constant_Type'Length; 378 end if; 379 380 Index1 := Index2 + 1; 381 Find_Colon (Index2); 382 end if; 383 384 if Info.Kind = CND or else Info.Kind = CNU then 385 Info.Int_Value := 386 Parse_Int (Line (Index1 .. Index2 - 1), Info.Kind); 387 Info.Value_Len := Info.Int_Value.Abs_Value'Img'Length - 1; 388 389 if not Info.Int_Value.Positive then 390 Info.Value_Len := Info.Value_Len + 1; 391 end if; 392 393 else 394 Info.Text_Value := Field_Alloc; 395 Info.Value_Len := Info.Text_Value'Length; 396 end if; 397 398 if Info.Constant_Name.all = "SIZEOF_unsigned_int" then 399 Size_Of_Unsigned_Int := 400 8 * Integer (Info.Int_Value.Abs_Value); 401 end if; 402 403 when others => 404 null; 405 end case; 406 407 Index1 := Index2 + 1; 408 Index2 := Line'Last + 1; 409 Info.Comment := Field_Alloc; 410 411 if Info.Kind = TXT then 412 Info.Text_Value := Info.Comment; 413 414 -- Update Max_Constant_Value_Len, but only if this constant has a 415 -- comment (else the value is allowed to be longer). 416 417 elsif Info.Comment'Length > 0 then 418 if Info.Value_Len > Max_Constant_Value_Len then 419 Max_Constant_Value_Len := Info.Value_Len; 420 end if; 421 end if; 422 423 Asm_Infos.Append (Info); 424 end; 425 426 exception 427 when E : others => 428 Put_Line 429 (Standard_Error, "can't parse " & Line); 430 Put_Line 431 (Standard_Error, "exception raised: " & Exception_Information (E)); 432 end Parse_Asm_Line; 433 434 ---------------- 435 -- Parse_Cond -- 436 ---------------- 437 438 procedure Parse_Cond 439 (If_Line : String; 440 Cond : Boolean; 441 Tmpl_File : Ada.Text_IO.File_Type; 442 Ada_Ofile, C_Ofile : Sfile; 443 Current_Line : in out Integer) 444 is 445 function Get_Value (Name : String) return Int_Value_Type; 446 -- Returns the value of the variable Name 447 448 --------------- 449 -- Get_Value -- 450 --------------- 451 452 function Get_Value (Name : String) return Int_Value_Type is 453 begin 454 if Is_Subset (To_Set (Name), Decimal_Digit_Set) then 455 return Parse_Int (Name, CND); 456 457 else 458 for K in 1 .. Asm_Infos.Last loop 459 if Asm_Infos.Table (K).Constant_Name /= null then 460 if Name = Asm_Infos.Table (K).Constant_Name.all then 461 return Asm_Infos.Table (K).Int_Value; 462 end if; 463 end if; 464 end loop; 465 466 -- Not found returns 0 467 468 return (True, 0); 469 end if; 470 end Get_Value; 471 472 -- Local variables 473 474 Sline : Slice_Set; 475 Line : String (1 .. 256); 476 Last : Integer; 477 Value1 : Int_Value_Type; 478 Value2 : Int_Value_Type; 479 Res : Boolean; 480 481 -- Start of processing for Parse_Cond 482 483 begin 484 Create (Sline, If_Line, " "); 485 486 if Slice_Count (Sline) /= 4 then 487 Put_Line (Standard_Error, "can't parse " & If_Line); 488 end if; 489 490 Value1 := Get_Value (Slice (Sline, 2)); 491 Value2 := Get_Value (Slice (Sline, 4)); 492 493 if Slice (Sline, 3) = ">" then 494 Res := Cond and (Value1 > Value2); 495 496 elsif Slice (Sline, 3) = "<" then 497 Res := Cond and (Value1 < Value2); 498 499 elsif Slice (Sline, 3) = "=" then 500 Res := Cond and (Value1 = Value2); 501 502 elsif Slice (Sline, 3) = "/=" then 503 Res := Cond and (Value1 /= Value2); 504 505 else 506 -- No other operator can be used 507 508 Put_Line (Standard_Error, "unknown operator in " & If_Line); 509 Res := False; 510 end if; 511 512 Current_Line := Current_Line + 1; 513 514 loop 515 Get_Line (Tmpl_File, Line, Last); 516 Current_Line := Current_Line + 1; 517 exit when Line (1 .. Last) = "@END_IF"; 518 519 if Line (1 .. 4) = "@IF " then 520 Parse_Cond 521 (Line (1 .. Last), Res, 522 Tmpl_File, Ada_Ofile, C_Ofile, Current_Line); 523 524 elsif Line (1 .. Last) = "@ELSE" then 525 Res := Cond and not Res; 526 527 elsif Res then 528 Put_Line (Ada_OFile, Line (1 .. Last)); 529 Put_Line (C_OFile, Line (1 .. Last)); 530 end if; 531 end loop; 532 end Parse_Cond; 533 534 --------------- 535 -- Parse_Int -- 536 --------------- 537 538 function Parse_Int 539 (S : String; 540 K : Asm_Int_Kind) return Int_Value_Type 541 is 542 First : Integer := S'First; 543 Result : Int_Value_Type; 544 545 begin 546 -- On some platforms, immediate integer values are prefixed with 547 -- a $ or # character in assembly output. 548 549 if S (First) = '$' or else S (First) = '#' then 550 First := First + 1; 551 end if; 552 553 if S (First) = '-' then 554 Result.Positive := False; 555 First := First + 1; 556 else 557 Result.Positive := True; 558 end if; 559 560 Result.Abs_Value := Long_Unsigned'Value (S (First .. S'Last)); 561 562 if not Result.Positive and then K = CNU then 563 564 -- Negative value, but unsigned expected: take 2's complement 565 -- reciprocical value. 566 567 Result.Abs_Value := ((not Result.Abs_Value) + 1) 568 and 569 (Shift_Left (1, Size_Of_Unsigned_Int) - 1); 570 Result.Positive := True; 571 end if; 572 573 return Result; 574 575 exception 576 when others => 577 Put_Line (Standard_Error, "can't parse decimal value: " & S); 578 raise; 579 end Parse_Int; 580 581 ------------ 582 -- Spaces -- 583 ------------ 584 585 function Spaces (Count : Integer) return String is 586 begin 587 if Count <= 0 then 588 return ""; 589 else 590 return (1 .. Count => ' '); 591 end if; 592 end Spaces; 593 594 -- Local declarations 595 596 -- Input files 597 598 Tmpl_File_Name : constant String := Tmpl_Name & ".i"; 599 Asm_File_Name : constant String := Tmpl_Name & ".s"; 600 601 -- Output files 602 603 Ada_File_Name : constant String := Unit_Name & ".ads"; 604 C_File_Name : constant String := Unit_Name & ".h"; 605 606 Asm_File : Ada.Text_IO.File_Type; 607 Tmpl_File : Ada.Text_IO.File_Type; 608 Ada_OFile : Sfile; 609 C_OFile : Sfile; 610 611 Line : String (1 .. 256); 612 Last : Integer; 613 -- Line being processed 614 615 Current_Line : Integer; 616 Current_Info : Integer; 617 In_Comment : Boolean; 618 In_Template : Boolean; 619 620-- Start of processing for XOSCons 621 622begin 623 -- Load values from assembly file 624 625 Open (Asm_File, In_File, Asm_File_Name); 626 while not End_Of_File (Asm_File) loop 627 Get_Line (Asm_File, Line, Last); 628 if Last > 2 and then Line (1 .. 2) = "->" then 629 Parse_Asm_Line (Line (3 .. Last)); 630 end if; 631 end loop; 632 633 Close (Asm_File); 634 635 -- Load C template and output definitions 636 637 Open (Tmpl_File, In_File, Tmpl_File_Name); 638 Create (Ada_OFile, Out_File, Ada_File_Name); 639 Create (C_OFile, Out_File, C_File_Name); 640 641 Current_Line := 0; 642 Current_Info := Asm_Infos.First; 643 In_Comment := False; 644 645 while not End_Of_File (Tmpl_File) loop 646 <<Get_One_Line>> 647 Get_Line (Tmpl_File, Line, Last); 648 649 if Last >= 2 and then Line (1 .. 2) = "# " then 650 declare 651 Index : Integer; 652 653 begin 654 Index := 3; 655 while Index <= Last and then Line (Index) in '0' .. '9' loop 656 Index := Index + 1; 657 end loop; 658 659 if Contains_Template_Name (Line (Index + 1 .. Last)) then 660 Current_Line := Integer'Value (Line (3 .. Index - 1)); 661 In_Template := True; 662 goto Get_One_Line; 663 else 664 In_Template := False; 665 end if; 666 end; 667 668 elsif In_Template then 669 if In_Comment then 670 if Line (1 .. Last) = "*/" then 671 Put_Line (C_OFile, Line (1 .. Last)); 672 In_Comment := False; 673 674 elsif Last > 4 and then Line (1 .. 4) = "@IF " then 675 Parse_Cond 676 (Line (1 .. Last), True, 677 Tmpl_File, Ada_Ofile, C_Ofile, Current_Line); 678 679 else 680 Put_Line (Ada_OFile, Line (1 .. Last)); 681 Put_Line (C_OFile, Line (1 .. Last)); 682 end if; 683 684 elsif Line (1 .. Last) = "/*" then 685 Put_Line (C_OFile, Line (1 .. Last)); 686 In_Comment := True; 687 688 elsif Asm_Infos.Table (Current_Info).Line_Number = Current_Line then 689 if Fixed.Index (Line, "/*NOGEN*/") = 0 then 690 Output_Info (Lang_Ada, Ada_OFile, Current_Info); 691 Output_Info (Lang_C, C_OFile, Current_Info); 692 end if; 693 694 Current_Info := Current_Info + 1; 695 end if; 696 697 Current_Line := Current_Line + 1; 698 end if; 699 end loop; 700 701 Close (Tmpl_File); 702 703exception 704 when others => 705 Put_Line ("xoscons <base_name>"); 706end XOSCons; 707