1------------------------------------------------------------------------------ 2-- Templates Parser -- 3-- -- 4-- Copyright (C) 2010-2014, AdaCore -- 5-- -- 6-- This library is free software; you can redistribute it and/or modify -- 7-- it under terms of the GNU General Public License as published by the -- 8-- Free Software Foundation; either version 3, or (at your option) any -- 9-- later version. This library is distributed in the hope that it will be -- 10-- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of -- 11-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12-- -- 13-- As a special exception under Section 7 of GPL version 3, you are -- 14-- granted additional permissions described in the GCC Runtime Library -- 15-- Exception, version 3.1, as published by the Free Software Foundation. -- 16-- -- 17-- You should have received a copy of the GNU General Public License and -- 18-- a copy of the GCC Runtime Library Exception along with this program; -- 19-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20-- <http://www.gnu.org/licenses/>. -- 21-- -- 22-- As a special exception, if other files instantiate generics from this -- 23-- unit, or you link this unit with other files to produce an executable, -- 24-- this unit does not by itself cause the resulting executable to be -- 25-- covered by the GNU General Public License. This exception does not -- 26-- however invalidate any other reasons why the executable file might be -- 27-- covered by the GNU Public License. -- 28------------------------------------------------------------------------------ 29 30pragma Ada_2012; 31 32with Ada.Containers.Indefinite_Hashed_Maps; 33with Ada.Strings.Hash_Case_Insensitive; 34with Ada.Text_IO; 35 36separate (Templates_Parser) 37 38package body Macro is 39 40 function Default_Callback 41 (Name : String; Params : Parameter_Set) return String; 42 -- Default macro callback 43 44 package Registry is new Containers.Indefinite_Hashed_Maps 45 (String, Tree, Strings.Hash_Case_Insensitive, "="); 46 47 Set : Registry.Map; 48 49 ---------------------- 50 -- Default_Callback -- 51 ---------------------- 52 53 function Default_Callback 54 (Name : String; Params : Parameter_Set) return String 55 is 56 function Parameters return String; 57 -- Returns parameters 58 59 ---------------- 60 -- Parameters -- 61 ---------------- 62 63 function Parameters return String is 64 R : Unbounded_String; 65 begin 66 for K in Params'Range loop 67 Append (R, Params (K)); 68 69 if K /= Params'Last then 70 Append (R, ","); 71 end if; 72 end loop; 73 74 return To_String (R); 75 end Parameters; 76 77 begin 78 return To_String (Begin_Tag) & Name 79 & "(" & Parameters & ")" & To_String (End_Tag); 80 end Default_Callback; 81 82 --------- 83 -- Get -- 84 --------- 85 86 function Get (Name : String) return Tree is 87 Position : constant Registry.Cursor := Set.Find (Name); 88 begin 89 if Registry.Has_Element (Position) then 90 return Registry.Element (Position); 91 else 92 return null; 93 end if; 94 end Get; 95 96 -------------------------- 97 -- Print_Defined_Macros -- 98 -------------------------- 99 100 procedure Print_Defined_Macros is 101 begin 102 Text_IO.Put_Line ("------------------------------------- MACROS"); 103 104 for C in Set.Iterate loop 105 declare 106 Name : constant String := Registry.Key (C); 107 Macro : constant Tree := Registry.Element (C); 108 begin 109 Text_IO.Put_Line ("[MACRO] " & Name); 110 Print_Tree (Macro); 111 Text_IO.Put_Line ("[END_MACRO]"); 112 Text_IO.New_Line; 113 end; 114 end loop; 115 end Print_Defined_Macros; 116 117 -------------- 118 -- Register -- 119 -------------- 120 121 procedure Register (Name : String; T : Tree) is 122 Old : Tree := Get (Name); 123 begin 124 if Old /= null then 125 Set.Delete (Name); 126 Release (Old); 127 end if; 128 Set.Insert (Name, T); 129 end Register; 130 131 ------------- 132 -- Rewrite -- 133 ------------- 134 135 procedure Rewrite 136 (T : in out Tree; 137 Parameters : not null access Data.Parameter_Set) 138 is 139 use type Definitions.Tree; 140 141 procedure Rewrite_Tree 142 (T : in out Tree; 143 Parameters : not null access Data.Parameter_Set); 144 -- Recursivelly rewrite the whole tree 145 146 package Set_Var is new Containers.Indefinite_Hashed_Maps 147 (String, Definitions.Tree, Strings.Hash_Case_Insensitive, "="); 148 149 procedure Release_Definition (Position : Set_Var.Cursor); 150 -- Release definition tree pointed to by Position 151 152 Vars : Set_Var.Map; 153 154 ------------------------ 155 -- Release_Definition -- 156 ------------------------ 157 158 procedure Release_Definition (Position : Set_Var.Cursor) is 159 E : Definitions.Tree := Set_Var.Element (Position); 160 begin 161 Definitions.Release (E); 162 end Release_Definition; 163 164 ------------------ 165 -- Rewrite_Tree -- 166 ------------------ 167 168 procedure Rewrite_Tree 169 (T : in out Tree; 170 Parameters : not null access Data.Parameter_Set) 171 is 172 procedure Rewrite (T : in out Data.Tree); 173 -- Rewrite every variable references @_$N_@ (where N is a 174 -- number) by the corresponding variable or value found in 175 -- Parameters(N) or by the corresponding variable mapping in Vars. 176 177 procedure Rewrite (T : in out Expr.Tree); 178 -- Rewrite condition. 179 -- In @@IF@@ @_$N_@ = val 180 -- Replace $N by Parameters(N) or by the corresponding value in the 181 -- variable mapping or does nothing if Parameters(N) does not exist 182 -- or no variable mapping found. 183 184 procedure Rewrite (Included : in out Included_File_Info); 185 -- Process included files (from @@INCLUDE@@ or @@EXTENDS@@) 186 187 ------------- 188 -- Rewrite -- 189 ------------- 190 191 procedure Rewrite (T : in out Data.Tree) is 192 193 procedure Replace 194 (T, C, Prev : in out Data.Tree; Ref : Positive); 195 -- Replace node C with the parameters pointed to by Ref 196 197 procedure Replace 198 (T, C, Prev : in out Data.Tree; Value : String); 199 -- As above, but replace by Value 200 201 procedure Delete_Node (T : in out Data.Tree; C, Prev : Data.Tree); 202 -- Delete node C 203 204 ----------------- 205 -- Delete_Note -- 206 ----------------- 207 208 procedure Delete_Node 209 (T : in out Data.Tree; C, Prev : Data.Tree) 210 is 211 use type Data.Tree; 212 Old : Data.Tree; 213 begin 214 if Prev = null then 215 Old := T; 216 T := C.Next; 217 else 218 Old := C; 219 Prev.Next := C.Next; 220 end if; 221 Data.Release (Old, Single => True); 222 end Delete_Node; 223 224 ------------- 225 -- Replace -- 226 ------------- 227 228 procedure Replace 229 (T, C, Prev : in out Data.Tree; Ref : Positive) 230 is 231 use type Data.NKind; 232 use type Data.Tree; 233 New_Node : constant Data.Tree := Data.Clone (Parameters (Ref)); 234 begin 235 New_Node.Next := C.Next; 236 if Prev = null then 237 Data.Release (T, Single => True); 238 T := New_Node; 239 else 240 Data.Release (Prev.Next, Single => True); 241 Prev.Next := New_Node; 242 end if; 243 244 Prev := New_Node; 245 C := New_Node.Next; 246 end Replace; 247 248 procedure Replace 249 (T, C, Prev : in out Data.Tree; Value : String) 250 is 251 use type Data.Tree; 252 New_Node : constant Data.Tree := 253 new Data.Node' 254 (Data.Text, 255 Next => C.Next, 256 Value => To_Unbounded_String (Value)); 257 begin 258 if Prev = null then 259 Data.Release (T, Single => True); 260 T := New_Node; 261 else 262 Data.Release (Prev.Next, Single => True); 263 Prev.Next := New_Node; 264 end if; 265 266 Prev := New_Node; 267 C := New_Node.Next; 268 end Replace; 269 270 use type Data.Tree; 271 D, Prev : Data.Tree; 272 Moved : Boolean := False; 273 274 begin 275 D := T; 276 Prev := null; 277 278 while D /= null loop 279 case D.Kind is 280 when Data.Text => 281 null; 282 283 when Data.Var => 284 -- Rewrite also the macro call if any 285 286 if D.Var.Is_Macro then 287 Rewrite_Tree (D.Var.Def, Parameters); 288 289 else 290 if D.Var.N > 0 then 291 -- This is a reference to a parameter 292 293 if D.Var.N <= Parameters'Length 294 and then Parameters (D.Var.N) /= null 295 then 296 -- This is a reference to replace 297 Replace (T, D, Prev, D.Var.N); 298 299 else 300 -- This variable does not have reference, remove 301 -- it. 302 Delete_Node (T, D, Prev); 303 304 D := D.Next; 305 end if; 306 307 Moved := True; 308 309 elsif Vars.Contains (To_String (D.Var.Name)) then 310 -- This is a variable that exists into the map. 311 -- It means that this variable is actually the 312 -- name of a SET which actually has been passed 313 -- a reference to another variable. 314 315 declare 316 E : constant Definitions.Tree := 317 Vars.Element (To_String (D.Var.Name)); 318 begin 319 case E.N.Kind is 320 when Definitions.Const => 321 Replace 322 (T, D, Prev, To_String (E.N.Value)); 323 324 when Definitions.Ref => 325 if E.N.Ref <= Parameters'Length 326 and then Parameters (E.N.Ref) /= null 327 then 328 Replace (T, D, Prev, E.N.Ref); 329 else 330 Replace (T, D, Prev, ""); 331 end if; 332 333 when Definitions.Ref_Default => 334 if E.N.Ref <= Parameters'Length 335 and then Parameters (E.N.Ref) /= null 336 then 337 Replace (T, D, Prev, E.N.Ref); 338 else 339 Replace 340 (T, D, Prev, To_String (E.N.Value)); 341 end if; 342 end case; 343 end; 344 345 Moved := True; 346 end if; 347 end if; 348 end case; 349 350 if Moved then 351 Moved := False; 352 else 353 Prev := D; 354 D := D.Next; 355 end if; 356 end loop; 357 end Rewrite; 358 359 ------------- 360 -- Rewrite -- 361 ------------- 362 363 procedure Rewrite (T : in out Expr.Tree) is 364 use type Data.Tree; 365 use type Expr.Tree; 366 367 procedure Replace (T : in out Expr.Tree; Ref : Positive) 368 with Inline; 369 -- Replace T with the parameters pointed to by Ref 370 371 procedure Replace (T : in out Expr.Tree; Value : String) 372 with Inline; 373 -- Replace the node by the given value 374 375 ------------- 376 -- Replace -- 377 ------------- 378 379 procedure Replace (T : in out Expr.Tree; Value : String) is 380 Ctx : aliased Filter.Filter_Context (0); 381 N_Value : constant String := 382 Data.Translate 383 (T.Var, Value, Ctx'Access); 384 begin 385 Expr.Release (T, Single => True); 386 T := new Expr.Node' 387 (Expr.Value, V => To_Unbounded_String (N_Value)); 388 end Replace; 389 390 procedure Replace (T : in out Expr.Tree; Ref : Positive) is 391 Ctx : aliased Filter.Filter_Context (0); 392 Tag_Var : Data.Tag_Var; 393 begin 394 case Parameters (Ref).Kind is 395 when Data.Text => 396 -- We need to evaluate the value against the filters 397 398 Replace 399 (T, 400 Data.Translate 401 (T.Var, 402 To_String (Parameters (Ref).Value), 403 Ctx'Access)); 404 405 when Data.Var => 406 Tag_Var := Data.Clone (Parameters (Ref).Var); 407 Data.Release (T.Var); 408 T.Var := Tag_Var; 409 end case; 410 end Replace; 411 412 begin 413 case T.Kind is 414 when Expr.Value => 415 null; 416 417 when Expr.Var => 418 if T.Var.N > 0 then 419 if T.Var.N <= Parameters'Length 420 and then Parameters (T.Var.N) /= null 421 then 422 -- This is a reference to replace 423 Replace (T, T.Var.N); 424 else 425 -- Referencing a parameter that does not exist 426 Replace (T, ""); 427 end if; 428 429 elsif Vars.Contains (To_String (T.Var.Name)) then 430 -- This is a variable that exists in the map. 431 -- It means that this variable is actually the 432 -- name of a SET which actually has been passed 433 -- a reference to another variable. 434 declare 435 E : constant Definitions.Tree := 436 Vars.Element (To_String (T.Var.Name)); 437 begin 438 case E.N.Kind is 439 when Definitions.Const => 440 Replace (T, To_String (E.N.Value)); 441 442 when Definitions.Ref => 443 if E.N.Ref <= Parameters'Length 444 and then Parameters (E.N.Ref) /= null 445 then 446 Replace (T, E.N.Ref); 447 else 448 Replace (T, ""); 449 end if; 450 451 when Definitions.Ref_Default => 452 null; 453 end case; 454 end; 455 456 else 457 -- Preserve the node as it is. It is likely refering to a 458 -- variable that was defined outside of the macro. 459 null; 460 end if; 461 462 when Expr.Op => 463 Rewrite (T.Left); 464 Rewrite (T.Right); 465 466 when Expr.U_Op => 467 Rewrite (T.Next); 468 end case; 469 end Rewrite; 470 471 ------------- 472 -- Rewrite -- 473 ------------- 474 475 procedure Rewrite (Included : in out Included_File_Info) is 476 begin 477 for K in Included.Params'Range loop 478 declare 479 use type Data.NKind; 480 use type Data.Tree; 481 P : Data.Tree renames Included.Params (K); 482 Old : Data.Tree; 483 begin 484 if P /= null 485 and then P.Kind = Data.Var 486 and then P.Var.N > 0 487 then 488 Old := Included.Params (K); 489 Included.Params (K) := Data.Clone (Parameters (P.Var.N)); 490 Data.Release (Old); 491 end if; 492 end; 493 end loop; 494 end Rewrite; 495 496 N : Tree := T; 497 Prev : Tree; 498 Moved : Boolean := False; 499 500 begin 501 T := N; 502 503 while N /= null loop 504 case N.Kind is 505 when Text => 506 Rewrite (N.Text); 507 508 when If_Stmt => 509 Rewrite (N.Cond); 510 Rewrite_Tree (N.N_True, Parameters); 511 Rewrite_Tree (N.N_False, Parameters); 512 513 when Set_Stmt => 514 -- Record definition and delete node, note that the 515 -- defintion tree will be freed later as we need the tree 516 -- for the rewriting. 517 518 Vars.Include (To_String (N.Def.Name), N.Def); 519 520 declare 521 Old : Tree := N; 522 begin 523 if Prev = null then 524 T := N.Next; 525 N := T; 526 else 527 Prev.Next := N.Next; 528 N := Prev.Next; 529 end if; 530 531 Unchecked_Free (Old); 532 533 Moved := True; 534 end; 535 536 when Table_Stmt => 537 Rewrite_Tree (N.Blocks, Parameters); 538 539 when Section_Block => 540 Rewrite_Tree (N.Common, Parameters); 541 Rewrite_Tree (N.Sections, Parameters); 542 543 when Section_Stmt => 544 Rewrite_Tree (N.N_Section, Parameters); 545 546 when Include_Stmt => 547 Rewrite (N.I_Included); 548 549 when Extends_Stmt => 550 Rewrite (N.E_Included); 551 552 when others => 553 null; 554 end case; 555 556 if Moved then 557 Moved := False; 558 else 559 Prev := N; 560 N := N.Next; 561 end if; 562 end loop; 563 end Rewrite_Tree; 564 565 begin 566 Rewrite_Tree (T, Parameters); 567 568 Vars.Iterate (Release_Definition'Access); 569 end Rewrite; 570 571begin 572 Callback := Default_Callback'Access; 573end Macro; 574