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