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