gcc/ada/xeinfo.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                          GNAT SYSTEM UTILITIES                           --
   4 --                                                                          --
   5 --                               X E I N F O                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2020, 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 C header file einfo.h (C version of einfo.ads spec)
  27 --  for use by Gigi. This header file contains all definitions and access
  28 --  functions, but does not contain set procedures, since Gigi is not allowed
  29 --  to modify the GNAT tree.
  30
  31 --    Input files:
  32
  33 --       einfo.ads     spec of Einfo package
  34 --       einfo.adb     body of Einfo package
  35
  36 --    Output files:
  37
  38 --       einfo.h       corresponding C header file
  39
  40 --  Note: It is assumed that the input files have been compiled without errors
  41
  42 --  An optional argument allows the specification of an output file name to
  43 --  override the default einfo.h file name for the generated output file.
  44
  45 --  Most, but not all of the functions in Einfo can be inlined in the C header.
  46 --  They are the functions identified by pragma Inline in the spec. Functions
  47 --  that cannot be inlined are simply defined in the header.
  48
  49 with Ada.Command_Line;              use Ada.Command_Line;
  50 with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
  51 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
  52 with Ada.Strings.Maps;              use Ada.Strings.Maps;
  53 with Ada.Strings.Maps.Constants;    use Ada.Strings.Maps.Constants;
  54 with Ada.Text_IO;                   use Ada.Text_IO;
  55
  56 with GNAT.Spitbol;                  use GNAT.Spitbol;
  57 with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
  58 with GNAT.Spitbol.Table_Boolean;    use GNAT.Spitbol.Table_Boolean;
  59
  60 with CEinfo;
  61
  62 procedure XEinfo is
  63
  64    package TB renames GNAT.Spitbol.Table_Boolean;
  65
  66    Err : exception;
  67
  68    A         : VString := Nul;
  69    B         : VString := Nul;
  70    C         : VString := Nul;
  71    Expr      : VString := Nul;
  72    Filler    : VString := Nul;
  73    Fline     : VString := Nul;
  74    Formal    : VString := Nul;
  75    Formaltyp : VString := Nul;
  76    FN        : VString := Nul;
  77    Line      : VString := Nul;
  78    N         : VString := Nul;
  79    N1        : VString := Nul;
  80    N2        : VString := Nul;
  81    N3        : VString := Nul;
  82    Nam       : VString := Nul;
  83    Name      : VString := Nul;
  84    NewS      : VString := Nul;
  85    Nextlin   : VString := Nul;
  86    OldS      : VString := Nul;
  87    Rtn       : VString := Nul;
  88    Term      : VString := Nul;
  89
  90    InB : File_Type;
  91    --  Used to read initial header from body
  92
  93    InF   : File_Type;
  94    --  Used to read full text of both spec and body
  95
  96    Ofile : File_Type;
  97    --  Used to write output file
  98
  99    wsp      : constant Pattern := NSpan (' ' & ASCII.HT);
 100    Comment  : constant Pattern := wsp & "--";
 101    For_Rep  : constant Pattern := wsp & "for";
 102    Get_Func : constant Pattern := wsp * A & "function" & wsp
 103                                   & Break (' ') * Name;
 104    Inline   : constant Pattern := wsp & "pragma Inline (" & Break (')') * Name;
 105    Get_Pack : constant Pattern := wsp & "package ";
 106    Get_Enam : constant Pattern := wsp & Break (',') * N & ',';
 107    Find_Fun : constant Pattern := wsp & "function";
 108    F_Subtyp : constant Pattern := wsp * A & "subtype " & Break (' ') * N;
 109    G_Subtyp : constant Pattern := wsp & "subtype" & wsp & Break (' ') * NewS
 110                                   & wsp & "is" & wsp & Break (" ;") * OldS
 111                                   & wsp & ';' & wsp & Rtab (0);
 112    F_Typ    : constant Pattern := wsp * A & "type " & Break (' ') * N &
 113                                   " is (";
 114    Get_Nam  : constant Pattern := wsp * A & Break (",)") * Nam
 115                                   & Len (1) * Term;
 116    Get_Styp : constant Pattern := wsp * A & "subtype " & Break (' ') * N;
 117    Get_N1   : constant Pattern := wsp & Break (' ') * N1;
 118    Get_N2   : constant Pattern := wsp & "-- " & Rest * N2;
 119    Get_N3   : constant Pattern := wsp & Break (';') * N3;
 120    Get_FN   : constant Pattern := wsp * C & "function" & wsp
 121                                   & Break (" (") * FN;
 122    Is_Rturn : constant Pattern := BreakX ('r') & "return";
 123    Is_Begin : constant Pattern := wsp & "begin";
 124    Get_Asrt : constant Pattern := wsp & "pragma Assert";
 125    Semicoln : constant Pattern := BreakX (';');
 126    Get_Cmnt : constant Pattern := BreakX ('-') * A & "--";
 127    Get_Expr : constant Pattern := wsp & "return " & Break (';') * Expr;
 128    Chek_End : constant Pattern := wsp & "end" & BreakX (';') & ';';
 129    Get_B0   : constant Pattern := BreakX (' ') * A & " or else " & Rest * B;
 130    Get_B1   : constant Pattern := BreakX (' ') * A & " in " & Rest * B;
 131    Get_B2   : constant Pattern := BreakX (' ') * A & " = " & Rest * B;
 132    Get_B3   : constant Pattern := BreakX (' ') * A & " /= " & Rest * B;
 133    To_Paren : constant Pattern := wsp * Filler & '(';
 134    Get_Fml  : constant Pattern := Break (" :") * Formal & wsp & ':' & wsp
 135                                   & BreakX (" );") * Formaltyp;
 136    Nxt_Fml  : constant Pattern := wsp & "; ";
 137    Get_Rtn  : constant Pattern := wsp & "return" & wsp & BreakX (" ;") * Rtn;
 138    Rem_Prn  : constant Pattern := wsp & ')';
 139
 140    M : Match_Result;
 141
 142    Lineno : Natural := 0;
 143    --  Line number in spec
 144
 145    V   : Natural;
 146    Ctr : Natural;
 147
 148    Inlined : TB.Table (200);
 149    --  Inlined<N> = True for inlined function, False otherwise
 150
 151    Lastinlined : Boolean;
 152
 153    procedure Badfunc;
 154    pragma No_Return (Badfunc);
 155    --  Signal bad function in body
 156
 157    function Getlin return VString;
 158    --  Get non-comment line (comment lines skipped, also skips FOR rep clauses)
 159    --  Fatal error (raises End_Error exception) if end of file encountered
 160
 161    procedure Must (B : Boolean);
 162    --  Raises Err if the argument (a Match) call, returns False
 163
 164    procedure Sethead (Line : in out VString; Term : String);
 165    --  Process function header into C
 166
 167    procedure Translate_Expr (Expr : in out VString);
 168    --  Translate expression from Ada to C
 169
 170    -------------
 171    -- Badfunc --
 172    -------------
 173
 174    procedure Badfunc is
 175    begin
 176       Put_Line
 177         (Standard_Error,
 178          "Body for function " & FN & " does not meet requirements");
 179       raise Err;
 180    end Badfunc;
 181
 182    -------------
 183    -- Getlin --
 184    -------------
 185
 186    function Getlin return VString is
 187       Lin : VString;
 188
 189    begin
 190       loop
 191          Lin := Get_Line (InF);
 192          Lineno := Lineno + 1;
 193
 194          if Lin /= ""
 195            and then not Match (Lin, Comment)
 196            and then not Match (Lin, For_Rep)
 197          then
 198             return Lin;
 199          end if;
 200       end loop;
 201    end Getlin;
 202
 203    ----------
 204    -- Must --
 205    ----------
 206
 207    procedure Must (B : Boolean) is
 208    begin
 209       if not B then
 210          raise Err;
 211       end if;
 212    end Must;
 213
 214    -------------
 215    -- Sethead --
 216    -------------
 217
 218    procedure Sethead (Line : in out VString; Term : String) is
 219       Args : VString;
 220
 221    begin
 222       Must (Match (Line, Get_Func, ""));
 223       Args := Nul;
 224
 225       if Match (Line, To_Paren, "") then
 226          Args := Filler & '(';
 227
 228          loop
 229             Must (Match (Line, Get_Fml, ""));
 230             Append (Args, Formaltyp & ' ' & Formal);
 231             exit when not Match (Line, Nxt_Fml);
 232             Append (Args, ",");
 233          end loop;
 234
 235          Match (Line, Rem_Prn, "");
 236          Append (Args, ')');
 237       end if;
 238
 239       Must (Match (Line, Get_Rtn));
 240
 241       if Present (Inlined, Name) then
 242          Put_Line (Ofile, A & "INLINE " & Rtn & ' ' & Name & Args & Term);
 243       else
 244          Put_Line (Ofile, A &  Rtn & ' ' & Name & Args & Term);
 245       end if;
 246    end Sethead;
 247
 248    --------------------
 249    -- Translate_Expr --
 250    --------------------
 251
 252    procedure Translate_Expr (Expr : in out VString) is
 253       M : Match_Result;
 254
 255    begin
 256       Match (Expr, Get_B1, M);
 257       Replace (M, "IN (" & A & ", " & B & ')');
 258       Match (Expr, Get_B2, M);
 259       Replace (M, A & " == " & B);
 260       Match (Expr, Get_B3, M);
 261       Replace (M, A & " != " & B);
 262    end Translate_Expr;
 263
 264 --  Start of processing for XEinfo
 265
 266 begin
 267    --  First run CEinfo to check for errors. Note that CEinfo is also a
 268    --  stand-alone program that can be run separately.
 269
 270    CEinfo;
 271
 272    Anchored_Mode := True;
 273
 274    if Argument_Count > 0 then
 275       Create (Ofile, Out_File, Argument (1));
 276    else
 277       Create (Ofile, Out_File, "einfo.h");
 278    end if;
 279
 280    Open (InB, In_File, "einfo.adb");
 281    Open (InF, In_File, "einfo.ads");
 282
 283    Lineno := 0;
 284    loop
 285       Line := Get_Line (InF);
 286       Lineno := Lineno + 1;
 287       exit when Line = "";
 288
 289       Match (Line,
 290              "--                                 S p e c       ",
 291              "--                              C Header File    ");
 292       Match (Line, "--", "/*");
 293       Match (Line, Rtab (2) * A & "--", M);
 294       Replace (M, A & "*/");
 295       Put_Line (Ofile, Line);
 296    end loop;
 297
 298    Put_Line (Ofile, "");
 299
 300    Put_Line (Ofile, "#ifdef __cplusplus");
 301    Put_Line (Ofile, "extern ""C"" {");
 302    Put_Line (Ofile, "#endif");
 303
 304    --  Find and record pragma Inlines
 305
 306    loop
 307       Line := Get_Line (InF);
 308       exit when Match (Line, "   --  END XEINFO INLINES");
 309
 310       if Match (Line, Inline) then
 311          Set (Inlined, Name, True);
 312       end if;
 313    end loop;
 314
 315    --  Skip to package line
 316
 317    Reset (InF, In_File);
 318    Lineno := 0;
 319
 320    loop
 321       Line := Getlin;
 322       exit when Match (Line, Get_Pack);
 323    end loop;
 324
 325    V := 0;
 326    Line := Getlin;
 327    Must (Match (Line, wsp & "type Entity_Kind"));
 328
 329    --  Process entity kind code definitions
 330
 331    loop
 332       Line := Getlin;
 333       exit when not Match (Line, Get_Enam);
 334       Put_Line (Ofile, "   #define " & Rpad (N, 32) & " " & V);
 335       V := V + 1;
 336    end loop;
 337
 338    Must (Match (Line, wsp & Rest * N));
 339    Put_Line (Ofile, "   #define " & Rpad (N, 32) & ' ' & V);
 340    Line := Getlin;
 341
 342    Must (Match (Line, wsp & ");"));
 343    Put_Line (Ofile, "");
 344
 345    --  Loop through subtype and type declarations
 346
 347    loop
 348       Line := Getlin;
 349       exit when Match (Line, Find_Fun);
 350
 351       --  Case of a subtype declaration
 352
 353       if Match (Line, F_Subtyp) then
 354
 355          --  Case of a subtype declaration that is an abbreviation of the
 356          --  form subtype x is y, and if so generate the appropriate typedef
 357
 358          if Match (Line, G_Subtyp) then
 359             Put_Line (Ofile, A & "typedef " & OldS & ' ' & NewS & ';');
 360
 361          --  Otherwise the subtype must be declaring a subrange of Entity_Id
 362
 363          else
 364             Must (Match (Line, Get_Styp));
 365             Line := Getlin;
 366             Must (Match (Line, Get_N1));
 367
 368             loop
 369                Line := Get_Line (InF);
 370                Lineno := Lineno + 1;
 371                exit when not Match (Line, Get_N2);
 372             end loop;
 373
 374             Must (Match (Line, Get_N3));
 375             Put_Line (Ofile, A & "SUBTYPE (" & N & ", Entity_Kind, ");
 376             Put_Line (Ofile, A & "   " & N1 & ", " & N3 & ')');
 377             Put_Line (Ofile, "");
 378          end if;
 379
 380       --  Case of type declaration
 381
 382       elsif Match (Line, F_Typ) then
 383
 384          --  Process type declaration (must be enumeration type)
 385
 386          Ctr := 0;
 387          Put_Line (Ofile, A & "typedef char " & N & ';');
 388
 389          loop
 390             Line := Getlin;
 391             Must (Match (Line, Get_Nam));
 392             Put_Line (Ofile, A & "#define " & Rpad (Nam, 25) & Ctr);
 393             Ctr := Ctr + 1;
 394             exit when Term /= ",";
 395          end loop;
 396
 397          Put_Line (Ofile, "");
 398
 399       --  Neither subtype nor type declaration
 400
 401       else
 402          raise Err;
 403       end if;
 404    end loop;
 405
 406    --  Process function declarations
 407
 408    --  Note: Lastinlined used to control blank lines
 409
 410    Put_Line (Ofile, "");
 411    Lastinlined := True;
 412
 413    --  Loop through function declarations
 414
 415    while Match (Line, Get_FN) loop
 416
 417       --  Non-inlined function
 418
 419       if not Present (Inlined, FN) then
 420          Put_Line (Ofile, "");
 421          Put_Line
 422            (Ofile,
 423             "   #define " & FN & " einfo__" & Translate (FN, Lower_Case_Map));
 424
 425       --  Inlined function
 426
 427       else
 428          if not Lastinlined then
 429             Put_Line (Ofile, "");
 430          end if;
 431       end if;
 432
 433       --  Merge here to output spec
 434
 435       Sethead (Line, ";");
 436       Lastinlined := Get (Inlined, FN);
 437       Line := Getlin;
 438    end loop;
 439
 440    Put_Line (Ofile, "");
 441
 442    --  Read body to find inlined functions
 443
 444    Close (InB);
 445    Close (InF);
 446    Open (InF, In_File, "einfo.adb");
 447    Lineno := 0;
 448
 449    --  Loop through input lines to find bodies of inlined functions
 450
 451    while not End_Of_File (InF) loop
 452       Fline := Get_Line (InF);
 453
 454       if Match (Fline, Get_FN)
 455         and then Get (Inlined, FN)
 456       then
 457          --  Here we have an inlined function
 458
 459          if not Match (Fline, Is_Rturn) then
 460             Line := Fline;
 461             Badfunc;
 462          end if;
 463
 464          Line := Getlin;
 465
 466          if not Match (Line, Is_Begin) then
 467             Badfunc;
 468          end if;
 469
 470          --  Skip past pragma Asserts
 471
 472          loop
 473             Line := Getlin;
 474             exit when not Match (Line, Get_Asrt);
 475
 476             --  Pragma assert found, get its continuation lines
 477
 478             loop
 479                exit when Match (Line, Semicoln);
 480                Line := Getlin;
 481             end loop;
 482          end loop;
 483
 484          --  Process return statement
 485
 486          Match (Line, Get_Cmnt, M);
 487          Replace (M, A);
 488
 489          --  Get continuations of return statement
 490
 491          while not Match (Line, Semicoln) loop
 492             Nextlin := Getlin;
 493             Match (Nextlin, wsp, " ");
 494             Append (Line, Nextlin);
 495          end loop;
 496
 497          if not Match (Line, Get_Expr) then
 498             Badfunc;
 499          end if;
 500
 501          Line := Getlin;
 502
 503          if not Match (Line, Chek_End) then
 504             Badfunc;
 505          end if;
 506
 507          --  Process expression
 508
 509          if Match (Expr, Get_B0, M) then
 510             declare
 511                Saved_A : VString := A;
 512                Saved_B : VString := B;
 513             begin
 514                Translate_Expr (Saved_A);
 515                Translate_Expr (Saved_B);
 516                Replace (M, Saved_A & " || " & Saved_B);
 517             end;
 518          else
 519             Translate_Expr (Expr);
 520          end if;
 521
 522          Put_Line (Ofile, "");
 523          Sethead (Fline, "");
 524          Put_Line (Ofile, C & "   { return " & Expr & "; }");
 525       end if;
 526    end loop;
 527
 528    Put_Line (Ofile, "");
 529
 530    Put_Line (Ofile, "#ifdef __cplusplus");
 531    Put_Line (Ofile, "}");
 532    Put_Line (Ofile, "#endif");
 533
 534    Put_Line
 535      (Ofile,
 536       "/* End of einfo.h (C version of Einfo package specification) */");
 537
 538    Close (InF);
 539    Close (Ofile);
 540
 541 exception
 542    when Err =>
 543       Put_Line (Standard_Error, Lineno & ".  " & Line);
 544       Put_Line (Standard_Error, "**** fatal error ****");
 545       Set_Exit_Status (1);
 546
 547    when End_Error =>
 548       Put_Line (Standard_Error, "unexpected end of file");
 549       Put_Line (Standard_Error, "**** fatal error ****");
 550
 551 end XEinfo;