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