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