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.2 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001 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.2 $", "$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       if Match (Line, Inline) then
 316          Set (Inlined, Name, True);
 317       end if;
 318    end loop;
 319
 320    --  Skip to package line
 321
 322    Reset (InF, In_File);
 323    Lineno := 0;
 324
 325    loop
 326       Line := Getlin;
 327       exit when Match (Line, Get_Pack);
 328    end loop;
 329
 330    V := 0;
 331    Line := Getlin;
 332    Must (Match (Line, wsp & "type Entity_Kind"));
 333
 334    --  Process entity kind code definitions
 335
 336    loop
 337       Line := Getlin;
 338       exit when not Match (Line, Get_Enam);
 339       Put_Line (Ofile, "   #define " & Rpad (N, 32) & " " & V);
 340       V := V + 1;
 341    end loop;
 342
 343    Must (Match (Line, wsp & Rest * N));
 344    Put_Line (Ofile, "   #define " & Rpad (N, 32) & ' ' & V);
 345    Line := Getlin;
 346
 347    Must (Match (Line, wsp & ");"));
 348    Put_Line (Ofile, "");
 349
 350    --  Loop through subtype and type declarations
 351
 352    loop
 353       Line := Getlin;
 354       exit when Match (Line, Find_Fun);
 355
 356       --  Case of a subtype declaration
 357
 358       if Match (Line, F_Subtyp) then
 359
 360          --  Case of a subtype declaration that is an abbreviation of the
 361          --  form subtype x is y, and if so generate the appropriate typedef
 362
 363          if Match (Line, G_Subtyp) then
 364             Put_Line (Ofile, A & "typedef " & OldS & ' ' & NewS & ';');
 365
 366          --  Otherwise the subtype must be declaring a subrange of Entity_Id
 367
 368          else
 369             Must (Match (Line, Get_Styp));
 370             Line := Getlin;
 371             Must (Match (Line, Get_N1));
 372
 373             loop
 374                Line := Get_Line (InF);
 375                Lineno := Lineno + 1;
 376                exit when not Match (Line, Get_N2);
 377             end loop;
 378
 379             Must (Match (Line, Get_N3));
 380             Put_Line (Ofile, A & "SUBTYPE (" & N & ", Entity_Kind, ");
 381             Put_Line (Ofile, A & "   " & N1 & ", " & N3 & ')');
 382             Put_Line (Ofile, "");
 383          end if;
 384
 385       --  Case of type declaration
 386
 387       elsif Match (Line, F_Typ) then
 388          --  Process type declaration (must be enumeration type)
 389
 390          Ctr := 0;
 391          Put_Line (Ofile, A & "typedef char " & N & ';');
 392
 393          loop
 394             Line := Getlin;
 395             Must (Match (Line, Get_Nam));
 396             Put_Line (Ofile, A & "#define " & Rpad (Nam, 25) & Ctr);
 397             Ctr := Ctr + 1;
 398             exit when Term /= ",";
 399          end loop;
 400
 401          Put_Line (Ofile, "");
 402
 403       --  Neither subtype nor type declaration
 404
 405       else
 406          raise Err;
 407       end if;
 408    end loop;
 409
 410    --  Process function declarations
 411    --  Note: Lastinlined used to control blank lines
 412
 413    Put_Line (Ofile, "");
 414    Lastinlined := True;
 415
 416    --  Loop through function declarations
 417
 418    while Match (Line, Get_FN) loop
 419
 420       --  Non-inlined function
 421
 422       if not Present (Inlined, FN) then
 423          Put_Line (Ofile, "");
 424          Put_Line
 425            (Ofile,
 426             "   #define " & FN & " einfo__" & Translate (FN, Lower_Case_Map));
 427
 428       --  Inlined function
 429
 430       else
 431          if not Lastinlined then
 432             Put_Line (Ofile, "");
 433          end if;
 434       end if;
 435
 436       --  Merge here to output spec
 437
 438       Sethead (Line, ";");
 439       Lastinlined := Get (Inlined, FN);
 440       Line := Getlin;
 441    end loop;
 442
 443    Put_Line (Ofile, "");
 444
 445    --  Read body to find inlined functions
 446
 447    Close (InB);
 448    Close (InF);
 449    Open (InF, In_File, "einfo.adb");
 450    Lineno := 0;
 451
 452    --  Loop through input lines to find bodies of inlined functions
 453
 454    while not End_Of_File (InF) loop
 455       Fline := Get_Line (InF);
 456
 457       if Match (Fline, Get_FN)
 458         and then Get (Inlined, FN)
 459       then
 460          --  Here we have an inlined function
 461
 462          if not Match (Fline, Is_Rturn) then
 463             Line := Fline;
 464             Badfunc;
 465          end if;
 466
 467          Line := Getlin;
 468
 469          if not Match (Line, Is_Begin) then
 470             Badfunc;
 471          end if;
 472
 473          --  Skip past pragma Asserts
 474
 475          loop
 476             Line := Getlin;
 477             exit when not Match (Line, Get_Asrt);
 478
 479             --  Pragma asser found, get its continuation lines
 480
 481             loop
 482                exit when Match (Line, Semicoln);
 483                Line := Getlin;
 484             end loop;
 485          end loop;
 486
 487          --  Process return statement
 488
 489          Match (Line, Get_Cmnt, M);
 490          Replace (M, A);
 491
 492          --  Get continuations of return statemnt
 493
 494          while not Match (Line, Semicoln) loop
 495             Nextlin := Getlin;
 496             Match (Nextlin, wsp, " ");
 497             Append (Line, Nextlin);
 498          end loop;
 499
 500          if not Match (Line, Get_Expr) then
 501             Badfunc;
 502          end if;
 503
 504          Line := Getlin;
 505
 506          if not Match (Line, Chek_End) then
 507             Badfunc;
 508          end if;
 509
 510          Match (Expr, Get_B1, M);
 511          Replace (M, "IN (" & A & ", " & B & ')');
 512          Match (Expr, Get_B2, M);
 513          Replace (M, A & " == " & B);
 514          Match (Expr, Get_B3, M);
 515          Replace (M, A & " != " & B);
 516          Put_Line (Ofile, "");
 517          Sethead (Fline, "");
 518          Put_Line (Ofile, C & "   { return " & Expr & "; }");
 519       end if;
 520    end loop;
 521
 522    Put_Line (Ofile, "");
 523    Put_Line
 524      (Ofile,
 525       "/* End of einfo.h (C version of Einfo package specification) */");
 526
 527 exception
 528    when Err =>
 529       Put_Line (Standard_Error, Lineno & ".  " & Line);
 530       Put_Line (Standard_Error, "**** fatal error ****");
 531       Set_Exit_Status (1);
 532
 533    when End_Error =>
 534       Put_Line (Standard_Error, "unexpected end of file");
 535       Put_Line (Standard_Error, "**** fatal error ****");
 536
 537 end XEinfo;