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