1-- Ortho debug back-end. 2-- Copyright (C) 2005 Tristan Gingold 3-- 4-- This program is free software: you can redistribute it and/or modify 5-- it under the terms of the GNU General Public License as published by 6-- the Free Software Foundation, either version 2 of the License, or 7-- (at your option) any later version. 8-- 9-- This program is distributed in the hope that it will be useful, 10-- but WITHOUT ANY WARRANTY; without even the implied warranty of 11-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12-- GNU General Public License for more details. 13-- 14-- You should have received a copy of the GNU General Public License 15-- along with this program. If not, see <gnu.org/licenses>. 16 17with Ada.Unchecked_Deallocation; 18 19package body Ortho_Debug is 20 -- If True, disable some checks so that the output can be generated. 21 Disable_Checks : constant Boolean := False; 22 23 type ON_Op_To_OE_Type is array (ON_Op_Kind) of OE_Kind; 24 ON_Op_To_OE : constant ON_Op_To_OE_Type := 25 ( 26 ON_Nil => OE_Nil, 27 28 -- Dyadic operations. 29 ON_Add_Ov => OE_Add_Ov, 30 ON_Sub_Ov => OE_Sub_Ov, 31 ON_Mul_Ov => OE_Mul_Ov, 32 ON_Div_Ov => OE_Div_Ov, 33 ON_Rem_Ov => OE_Rem_Ov, 34 ON_Mod_Ov => OE_Mod_Ov, 35 36 -- Binary operations. 37 ON_And => OE_And, 38 ON_Or => OE_Or, 39 ON_Xor => OE_Xor, 40 41 -- Monadic operations. 42 ON_Not => OE_Not, 43 ON_Neg_Ov => OE_Neg_Ov, 44 ON_Abs_Ov => OE_Abs_Ov, 45 46 -- Comparaisons 47 ON_Eq => OE_Eq, 48 ON_Neq => OE_Neq, 49 ON_Le => OE_Le, 50 ON_Lt => OE_Lt, 51 ON_Ge => OE_Ge, 52 ON_Gt => OE_Gt 53 ); 54 55 type Decl_Scope_Type is record 56 -- Declarations are chained. 57 Parent : O_Snode; 58 Last_Decl : O_Dnode; 59 Last_Stmt : O_Snode; 60 61 -- If this scope corresponds to a function, PREV_FUNCTION contains 62 -- the previous function. 63 Prev_Function : O_Dnode; 64 65 -- Declaration scopes are chained. 66 Prev : Decl_Scope_Acc; 67 end record; 68 69 type Stmt_Kind is 70 (Stmt_Function, Stmt_Declare, Stmt_If, Stmt_Loop, Stmt_Case); 71 type Stmt_Scope_Type (Kind : Stmt_Kind); 72 type Stmt_Scope_Acc is access Stmt_Scope_Type; 73 type Stmt_Scope_Type (Kind : Stmt_Kind) is record 74 -- Statement which created this scope. 75 Parent : O_Snode; 76 -- Previous (parent) scope. 77 Prev : Stmt_Scope_Acc; 78 case Kind is 79 when Stmt_Function => 80 Prev_Function : Stmt_Scope_Acc; 81 -- Declaration for the function. 82 Decl : O_Dnode; 83 when Stmt_Declare => 84 null; 85 when Stmt_If => 86 Last_Elsif : O_Snode; 87 when Stmt_Loop => 88 null; 89 when Stmt_Case => 90 Last_Branch : O_Snode; 91 Last_Choice : O_Choice; 92 Case_Type : O_Tnode; 93 end case; 94 end record; 95 subtype Stmt_Function_Scope_Type is Stmt_Scope_Type (Stmt_Function); 96 subtype Stmt_Declare_Scope_Type is Stmt_Scope_Type (Stmt_Declare); 97 subtype Stmt_If_Scope_Type is Stmt_Scope_Type (Stmt_If); 98 subtype Stmt_Loop_Scope_Type is Stmt_Scope_Type (Stmt_Loop); 99 subtype Stmt_Case_Scope_Type is Stmt_Scope_Type (Stmt_Case); 100 101 Current_Stmt_Scope : Stmt_Scope_Acc := null; 102 Current_Function : Stmt_Scope_Acc := null; 103 Current_Decl_Scope : Decl_Scope_Acc := null; 104 Current_Loop_Level : Natural := 0; 105 106 procedure Push_Decl_Scope (Parent : O_Snode) 107 is 108 Res : Decl_Scope_Acc; 109 begin 110 Res := new Decl_Scope_Type'(Parent => Parent, 111 Last_Decl => null, 112 Last_Stmt => null, 113 Prev_Function => null, 114 Prev => Current_Decl_Scope); 115 Parent.Alive := True; 116 Current_Decl_Scope := Res; 117 end Push_Decl_Scope; 118 119 procedure Pop_Decl_Scope 120 is 121 procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation 122 (Object => Decl_Scope_Type, Name => Decl_Scope_Acc); 123 Old : Decl_Scope_Acc; 124 begin 125 Old := Current_Decl_Scope; 126 Old.Parent.Alive := False; 127 Current_Decl_Scope := Old.Prev; 128 Unchecked_Deallocation (Old); 129 end Pop_Decl_Scope; 130 131 procedure Add_Decl (El : O_Dnode; Check_Dup : Boolean := True) is 132 begin 133 if Current_Decl_Scope = null then 134 -- Not yet initialized, or after compilation. 135 raise Program_Error; 136 end if; 137 138 -- Note: this requires an hashed ident table. 139 -- Use ortho_ident_hash. 140 if False and then Check_Dup 141 and then not Is_Nul (El.Name) 142 then 143 -- Check the name is not already defined. 144 declare 145 E : O_Dnode; 146 begin 147 E := Current_Decl_Scope.Parent.Decls; 148 while E /= O_Dnode_Null loop 149 if Is_Equal (E.Name, El.Name) then 150 raise Syntax_Error; 151 end if; 152 E := E.Next; 153 end loop; 154 end; 155 end if; 156 157 if Current_Decl_Scope.Last_Decl = null then 158 if Current_Decl_Scope.Parent.Kind = ON_Declare_Stmt then 159 Current_Decl_Scope.Parent.Decls := El; 160 else 161 raise Type_Error; 162 end if; 163 else 164 Current_Decl_Scope.Last_Decl.Next := El; 165 end if; 166 El.Next := null; 167 Current_Decl_Scope.Last_Decl := El; 168 end Add_Decl; 169 170 procedure Add_Stmt (Stmt : O_Snode) 171 is 172 begin 173 if Current_Decl_Scope = null or Current_Function = null then 174 -- You are adding a statement at the global level, ie not inside 175 -- a function. 176 raise Syntax_Error; 177 end if; 178 179 Stmt.Next := null; 180 if Current_Decl_Scope.Last_Stmt = null then 181 if Current_Decl_Scope.Parent.Kind = ON_Declare_Stmt then 182 Current_Decl_Scope.Parent.Stmts := Stmt; 183 else 184 raise Syntax_Error; 185 end if; 186 else 187 Current_Decl_Scope.Last_Stmt.Next := Stmt; 188 end if; 189 Current_Decl_Scope.Last_Stmt := Stmt; 190 end Add_Stmt; 191 192 procedure Push_Stmt_Scope (Scope : Stmt_Scope_Acc) 193 is 194 begin 195 if Scope.Prev /= Current_Stmt_Scope then 196 -- SCOPE was badly initialized. 197 raise Program_Error; 198 end if; 199 Current_Stmt_Scope := Scope; 200 end Push_Stmt_Scope; 201 202 procedure Pop_Stmt_Scope (Kind : Stmt_Kind) 203 is 204 procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation 205 (Object => Stmt_Scope_Type, Name => Stmt_Scope_Acc); 206 Old : Stmt_Scope_Acc; 207 begin 208 Old := Current_Stmt_Scope; 209 if Old.Kind /= Kind then 210 raise Syntax_Error; 211 end if; 212 --Old.Parent.Last_Stmt := Current_Decl_Scope.Last_Stmt; 213 Current_Stmt_Scope := Old.Prev; 214 Unchecked_Deallocation (Old); 215 end Pop_Stmt_Scope; 216 217 -- Check declaration DECL is reachable, ie its scope is in the current 218 -- stack of scopes. 219 procedure Check_Scope (Decl : O_Dnode) 220 is 221 Res : Boolean; 222 begin 223 if Disable_Checks then 224 return; 225 end if; 226 case Decl.Kind is 227 when ON_Interface_Decl => 228 Res := Decl.Func_Scope.Alive; 229 when others => 230 Res := Decl.Scope.Alive; 231 end case; 232 if not Res then 233 raise Syntax_Error; 234 end if; 235 end Check_Scope; 236 237 -- Raise SYNTAX_ERROR if OBJ is not at a constant address. 238-- procedure Check_Const_Address (Obj : O_Lnode) is 239-- begin 240-- case Obj.Kind is 241-- when OL_Const_Ref 242-- | OL_Var_Ref => 243-- case Obj.Decl.Storage is 244-- when O_Storage_External 245-- | O_Storage_Public 246-- | O_Storage_Private => 247-- null; 248-- when O_Storage_Local => 249-- raise Syntax_Error; 250-- end case; 251-- when others => 252-- -- FIXME: constant indexed element, selected element maybe 253-- -- of const address. 254-- raise Syntax_Error; 255-- end case; 256-- end Check_Const_Address; 257 258 procedure Check_Type (T1, T2 : O_Tnode) is 259 begin 260 if T1 = T2 then 261 return; 262 end if; 263 -- TODO: Two different subtypes with the same constraints are allowed. 264 -- Is it needed ? 265 if T1.Kind = ON_Array_Subtype and then T2.Kind = ON_Array_Subtype 266 and then T1.Arr_Base = T2.Arr_Base 267 and then T1.Arr_El_Type = T2.Arr_El_Type 268 and then T1.Length.all = T2.Length.all 269 then 270 return; 271 end if; 272 if not Disable_Checks then 273 raise Type_Error; 274 end if; 275 end Check_Type; 276 277 procedure Check_Ref (N : O_Enode) is 278 begin 279 if N.Ref then 280 -- Already referenced. 281 raise Syntax_Error; 282 end if; 283 N.Ref := True; 284 end Check_Ref; 285 286 procedure Check_Ref (N : O_Lnode) is 287 begin 288 if N.Ref then 289 raise Syntax_Error; 290 end if; 291 N.Ref := True; 292 end Check_Ref; 293 294 procedure Check_Ref (N : O_Gnode) is 295 begin 296 if N.Ref then 297 raise Syntax_Error; 298 end if; 299 N.Ref := True; 300 end Check_Ref; 301 302 procedure Check_Complete_Type (T : O_Tnode) is 303 begin 304 if not T.Complete then 305 -- Uncomplete type cannot be used here (since its size is required, 306 -- for example). 307 raise Syntax_Error; 308 end if; 309 end Check_Complete_Type; 310 311 procedure Check_Constrained_Type (T : O_Tnode) is 312 begin 313 if not T.Constrained then 314 -- Unconstrained type cannot be used here (since its size is 315 -- required, for example). 316 null; 317 raise Syntax_Error; 318 end if; 319 end Check_Constrained_Type; 320 321 function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) 322 return O_Enode 323 is 324 K : constant OE_Kind := ON_Op_To_OE (Kind); 325 Res : O_Enode; 326 begin 327 Check_Type (Left.Rtype, Right.Rtype); 328 Check_Ref (Left); 329 Check_Ref (Right); 330 Res := new O_Enode_Type (K); 331 Res.Rtype := Left.Rtype; 332 Res.Ref := False; 333 Res.Left := Left; 334 Res.Right := Right; 335 return Res; 336 end New_Dyadic_Op; 337 338 function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) 339 return O_Enode 340 is 341 Res : O_Enode; 342 begin 343 Check_Ref (Operand); 344 Res := new O_Enode_Type (ON_Op_To_OE (Kind)); 345 Res.Ref := False; 346 Res.Operand := Operand; 347 Res.Rtype := Operand.Rtype; 348 return Res; 349 end New_Monadic_Op; 350 351 function New_Compare_Op 352 (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) 353 return O_Enode 354 is 355 Res : O_Enode; 356 begin 357 if Ntype.Kind /= ON_Boolean_Type then 358 raise Type_Error; 359 end if; 360 if Left.Rtype /= Right.Rtype then 361 raise Type_Error; 362 end if; 363 Check_Ref (Left); 364 Check_Ref (Right); 365 Res := new O_Enode_Type (ON_Op_To_OE (Kind)); 366 Res.Ref := False; 367 Res.Left := Left; 368 Res.Right := Right; 369 Res.Rtype := Ntype; 370 return Res; 371 end New_Compare_Op; 372 373 374 function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) 375 return O_Cnode 376 is 377 subtype O_Cnode_Signed_Lit is O_Cnode_Type (OC_Signed_Lit); 378 begin 379 if Ltype.Kind = ON_Signed_Type then 380 return new O_Cnode_Signed_Lit'(Kind => OC_Signed_Lit, 381 Ctype => Ltype, 382 Ref => False, 383 S_Val => Value); 384 else 385 raise Type_Error; 386 end if; 387 end New_Signed_Literal; 388 389 function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) 390 return O_Cnode 391 is 392 subtype O_Cnode_Unsigned_Lit is O_Cnode_Type (OC_Unsigned_Lit); 393 begin 394 if Ltype.Kind = ON_Unsigned_Type then 395 return new O_Cnode_Unsigned_Lit'(Kind => OC_Unsigned_Lit, 396 Ctype => Ltype, 397 Ref => False, 398 U_Val => Value); 399 else 400 raise Type_Error; 401 end if; 402 end New_Unsigned_Literal; 403 404 function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) 405 return O_Cnode 406 is 407 subtype O_Cnode_Float_Lit is O_Cnode_Type (OC_Float_Lit); 408 begin 409 if Ltype.Kind = ON_Float_Type then 410 return new O_Cnode_Float_Lit'(Kind => OC_Float_Lit, 411 Ctype => Ltype, 412 Ref => False, 413 F_Val => Value); 414 else 415 raise Type_Error; 416 end if; 417 end New_Float_Literal; 418 419 function New_Null_Access (Ltype : O_Tnode) return O_Cnode 420 is 421 subtype O_Cnode_Null_Lit_Type is O_Cnode_Type (OC_Null_Lit); 422 begin 423 if Ltype.Kind /= ON_Access_Type then 424 raise Type_Error; 425 end if; 426 return new O_Cnode_Null_Lit_Type'(Kind => OC_Null_Lit, 427 Ctype => Ltype, 428 Ref => False); 429 end New_Null_Access; 430 431 function New_Default_Value (Ltype : O_Tnode) return O_Cnode 432 is 433 subtype O_Cnode_Default_Lit_Type is O_Cnode_Type (OC_Default_Lit); 434 begin 435 return new O_Cnode_Default_Lit_Type'(Kind => OC_Default_Lit, 436 Ctype => Ltype, 437 Ref => False); 438 end New_Default_Value; 439 440 function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is 441 begin 442 if Rtype.Kind /= ON_Unsigned_Type 443 and then Rtype.Kind /= ON_Access_Type 444 then 445 raise Type_Error; 446 end if; 447 Check_Complete_Type (Atype); 448 Check_Constrained_Type (Atype); 449 return new O_Cnode_Type'(Kind => OC_Sizeof_Lit, 450 Ctype => Rtype, 451 Ref => False, 452 S_Type => Atype); 453 end New_Sizeof; 454 455 function New_Record_Sizeof 456 (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is 457 begin 458 if Rtype.Kind /= ON_Unsigned_Type 459 and then Rtype.Kind /= ON_Access_Type 460 then 461 raise Type_Error; 462 end if; 463 Check_Complete_Type (Atype); 464 if Atype.Kind /= ON_Record_Type then 465 raise Type_Error; 466 end if; 467 return new O_Cnode_Type'(Kind => OC_Record_Sizeof_Lit, 468 Ctype => Rtype, 469 Ref => False, 470 S_Type => Atype); 471 end New_Record_Sizeof; 472 473 function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode 474 is 475 subtype O_Cnode_Alignof_Type is O_Cnode_Type (OC_Alignof_Lit); 476 begin 477 if Rtype.Kind /= ON_Unsigned_Type then 478 raise Type_Error; 479 end if; 480 Check_Complete_Type (Atype); 481 return new O_Cnode_Alignof_Type'(Kind => OC_Alignof_Lit, 482 Ctype => Rtype, 483 Ref => False, 484 S_Type => Atype); 485 end New_Alignof; 486 487 function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) 488 return O_Cnode 489 is 490 subtype O_Cnode_Offsetof_Type is O_Cnode_Type (OC_Offsetof_Lit); 491 begin 492 if Rtype.Kind /= ON_Unsigned_Type 493 and then Rtype.Kind /= ON_Access_Type 494 then 495 raise Type_Error; 496 end if; 497 if Field.Parent /= Atype then 498 raise Type_Error; 499 end if; 500 return new O_Cnode_Offsetof_Type'(Kind => OC_Offsetof_Lit, 501 Ctype => Rtype, 502 Ref => False, 503 Off_Field => Field); 504 end New_Offsetof; 505 506 function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode 507 is 508 subtype O_Enode_Alloca_Type is O_Enode_Type (OE_Alloca); 509 Res : O_Enode; 510 begin 511 if Rtype.Kind /= ON_Access_Type then 512 raise Type_Error; 513 end if; 514 if Size.Rtype.Kind /= ON_Unsigned_Type then 515 raise Type_Error; 516 end if; 517 Res := new O_Enode_Alloca_Type'(Kind => OE_Alloca, 518 Rtype => Rtype, 519 Ref => False, 520 A_Size => Size); 521 return Res; 522 end New_Alloca; 523 524 function Get_Base_Type (Atype : O_Tnode) return O_Tnode is 525 begin 526 case Atype.Kind is 527 when ON_Array_Subtype => 528 return Atype.Arr_Base; 529 when ON_Record_Subtype => 530 return Atype.Subrec_Base; 531 when others => 532 return Atype; 533 end case; 534 end Get_Base_Type; 535 536 procedure New_Completed_Type_Decl (Atype : O_Tnode) 537 is 538 N : O_Dnode; 539 begin 540 if Atype.Decl = null then 541 -- The uncompleted type must have been declared. 542 raise Type_Error; 543 end if; 544 N := new O_Dnode_Type (ON_Completed_Type_Decl); 545 N.Name := Atype.Decl.Name; 546 N.Dtype := Atype; 547 Add_Decl (N, False); 548 end New_Completed_Type_Decl; 549 550 procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is 551 begin 552 Res := new O_Tnode_Type'(Kind => ON_Record_Type, 553 Decl => O_Dnode_Null, 554 Uncomplete => True, 555 Complete => False, 556 Constrained => True, 557 Rec_Elements => O_Fnode_Null); 558 end New_Uncomplete_Record_Type; 559 560 procedure Start_Uncomplete_Record_Type (Res : O_Tnode; 561 Elements : out O_Element_List) is 562 begin 563 if not Res.Uncomplete then 564 -- RES record type is not an uncomplete record type. 565 raise Syntax_Error; 566 end if; 567 if Res.Rec_Elements /= O_Fnode_Null then 568 -- RES record type already has elements... 569 raise Syntax_Error; 570 end if; 571 Elements.Res := Res; 572 Elements.Last := null; 573 end Start_Uncomplete_Record_Type; 574 575 procedure Start_Record_Type (Elements : out O_Element_List) 576 is 577 Res : O_Tnode; 578 begin 579 Res := new O_Tnode_Type'(Kind => ON_Record_Type, 580 Decl => O_Dnode_Null, 581 Uncomplete => False, 582 Complete => False, 583 Constrained => True, 584 Rec_Elements => O_Fnode_Null); 585 Elements := (Res => Res, 586 Last => null); 587 end Start_Record_Type; 588 589 procedure New_Record_Field 590 (Elements : in out O_Element_List; 591 El : out O_Fnode; 592 Ident : O_Ident; Etype : O_Tnode) 593 is 594 begin 595 Check_Complete_Type (Etype); 596 if not Etype.Constrained then 597 Elements.Res.Constrained := False; 598 end if; 599 El := new O_Fnode_Type'(Parent => Elements.Res, 600 Next => null, 601 Ident => Ident, 602 Ftype => Etype); 603 -- Append EL. 604 if Elements.Last = null then 605 Elements.Res.Rec_Elements := El; 606 else 607 Elements.Last.Next := El; 608 end if; 609 Elements.Last := El; 610 end New_Record_Field; 611 612 procedure Finish_Record_Type 613 (Elements : in out O_Element_List; Res : out O_Tnode) is 614 begin 615 -- Align the structure. 616 Res := Elements.Res; 617 if Res.Uncomplete then 618 New_Completed_Type_Decl (Res); 619 end if; 620 Res.Complete := True; 621 end Finish_Record_Type; 622 623 procedure Start_Record_Subtype 624 (Rtype : O_Tnode; Elements : out O_Element_Sublist) 625 is 626 Res : O_Tnode; 627 begin 628 if Rtype.Kind /= ON_Record_Type then 629 raise Syntax_Error; 630 end if; 631 632 Res := new O_Tnode_Type'(Kind => ON_Record_Subtype, 633 Decl => O_Dnode_Null, 634 Uncomplete => False, 635 Complete => False, 636 Constrained => True, 637 Subrec_Elements => O_Fnode_Null, 638 Subrec_Base => Rtype); 639 Elements := (Res => Res, 640 Last => null, 641 Base_Field => Rtype.Rec_Elements); 642 end Start_Record_Subtype; 643 644 procedure New_Subrecord_Field 645 (Elements : in out O_Element_Sublist; El : out O_Fnode; Etype : O_Tnode) 646 is 647 Base_Field : O_Fnode; 648 begin 649 Check_Complete_Type (Etype); 650 Check_Constrained_Type (Etype); 651 652 Base_Field := Elements.Base_Field; 653 if Base_Field = O_Fnode_Null then 654 raise Syntax_Error; 655 end if; 656 if Base_Field.Ftype.Constrained then 657 -- For constrained field of the base type, the type must be the 658 -- same. 659 if Base_Field.Ftype /= Etype then 660 raise Syntax_Error; 661 end if; 662 else 663 -- Otherwise, must be a subtype. 664 if Get_Base_Type (Etype) /= Base_Field.Ftype then 665 raise Syntax_Error; 666 end if; 667 end if; 668 El := new O_Fnode_Type'(Parent => Elements.Res, 669 Next => null, 670 Ident => Base_Field.Ident, 671 Ftype => Etype); 672 673 -- Append EL. 674 if Elements.Last = null then 675 Elements.Res.Subrec_Elements := El; 676 else 677 Elements.Last.Next := El; 678 end if; 679 Elements.Last := El; 680 681 Elements.Base_Field := Base_Field.Next; 682 end New_Subrecord_Field; 683 684 procedure Finish_Record_Subtype 685 (Elements : in out O_Element_Sublist; Res : out O_Tnode) is 686 begin 687 Res := Elements.Res; 688 Res.Complete := True; 689 end Finish_Record_Subtype; 690 691 procedure Start_Union_Type (Elements : out O_Element_List) is 692 begin 693 Elements.Res := new O_Tnode_Type'(Kind => ON_Union_Type, 694 Decl => O_Dnode_Null, 695 Uncomplete => False, 696 Complete => False, 697 Constrained => True, 698 Rec_Elements => O_Fnode_Null); 699 Elements.Last := null; 700 end Start_Union_Type; 701 702 procedure New_Union_Field 703 (Elements : in out O_Element_List; 704 El : out O_Fnode; 705 Ident : O_Ident; Etype : O_Tnode) 706 is 707 begin 708 New_Record_Field (Elements, El, Ident, Etype); 709 end New_Union_Field; 710 711 procedure Finish_Union_Type 712 (Elements : in out O_Element_List; Res : out O_Tnode) is 713 begin 714 Res := Elements.Res; 715 Res.Complete := True; 716 end Finish_Union_Type; 717 718 function Is_Subtype (T : O_Tnode) return Boolean is 719 begin 720 case T.Kind is 721 when ON_Array_Subtype 722 | ON_Record_Subtype => 723 return True; 724 when others => 725 return False; 726 end case; 727 end Is_Subtype; 728 729 function New_Access_Type (Dtype : O_Tnode) return O_Tnode 730 is 731 subtype O_Tnode_Access is O_Tnode_Type (ON_Access_Type); 732 Res : O_Tnode; 733 begin 734 Res := new O_Tnode_Access'(Kind => ON_Access_Type, 735 Decl => O_Dnode_Null, 736 Uncomplete => Dtype = O_Tnode_Null, 737 Complete => True, 738 Constrained => True, 739 D_Type => Dtype); 740 return Res; 741 end New_Access_Type; 742 743 procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) is 744 begin 745 if Is_Subtype (Dtype) then 746 -- Access to sub array are not allowed, use access to array. 747 raise Type_Error; 748 end if; 749 if Atype.D_Type /= O_Tnode_Null 750 or Atype.Uncomplete = False 751 then 752 -- Type already completed. 753 raise Syntax_Error; 754 end if; 755 Atype.D_Type := Dtype; 756 New_Completed_Type_Decl (Atype); 757 end Finish_Access_Type; 758 759 function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) 760 return O_Tnode 761 is 762 subtype O_Tnode_Array is O_Tnode_Type (ON_Array_Type); 763 begin 764 Check_Complete_Type (El_Type); 765 return new O_Tnode_Array'(Kind => ON_Array_Type, 766 Decl => O_Dnode_Null, 767 Uncomplete => False, 768 Complete => True, 769 Constrained => False, -- By definition 770 El_Type => El_Type, 771 Index_Type => Index_Type); 772 end New_Array_Type; 773 774 function New_Array_Subtype 775 (Atype : O_Tnode; El_Type : O_Tnode; Length : O_Cnode) return O_Tnode 776 is 777 subtype O_Tnode_Sub_Array is O_Tnode_Type (ON_Array_Subtype); 778 begin 779 -- Can only constraint an array type. 780 if Atype.Kind /= ON_Array_Type then 781 raise Type_Error; 782 end if; 783 784 -- The element must either be ATYPE element or a constrained subtype 785 -- of it. 786 if El_Type /= Atype.El_Type then 787 if Get_Base_Type (El_Type) /= Atype.El_Type then 788 raise Type_Error; 789 end if; 790 end if; 791 Check_Constrained_Type (El_Type); 792 793 return new O_Tnode_Sub_Array'(Kind => ON_Array_Subtype, 794 Decl => O_Dnode_Null, 795 Uncomplete => False, 796 Complete => True, 797 Constrained => True, 798 Arr_Base => Atype, 799 Arr_El_Type => El_Type, 800 Length => Length); 801 end New_Array_Subtype; 802 803 function New_Unsigned_Type (Size : Natural) return O_Tnode 804 is 805 subtype O_Tnode_Unsigned is O_Tnode_Type (ON_Unsigned_Type); 806 begin 807 return new O_Tnode_Unsigned'(Kind => ON_Unsigned_Type, 808 Decl => O_Dnode_Null, 809 Uncomplete => False, 810 Complete => True, 811 Constrained => True, 812 Int_Size => Size); 813 end New_Unsigned_Type; 814 815 function New_Signed_Type (Size : Natural) return O_Tnode 816 is 817 subtype O_Tnode_Signed is O_Tnode_Type (ON_Signed_Type); 818 begin 819 return new O_Tnode_Signed'(Kind => ON_Signed_Type, 820 Decl => O_Dnode_Null, 821 Uncomplete => False, 822 Complete => True, 823 Constrained => True, 824 Int_Size => Size); 825 end New_Signed_Type; 826 827 function New_Float_Type return O_Tnode 828 is 829 subtype O_Tnode_Float is O_Tnode_Type (ON_Float_Type); 830 begin 831 return new O_Tnode_Float'(Kind => ON_Float_Type, 832 Decl => O_Dnode_Null, 833 Uncomplete => False, 834 Complete => True, 835 Constrained => True); 836 end New_Float_Type; 837 838 procedure New_Boolean_Type (Res : out O_Tnode; 839 False_Id : O_Ident; 840 False_E : out O_Cnode; 841 True_Id : O_Ident; 842 True_E : out O_Cnode) 843 is 844 subtype O_Tnode_Boolean is O_Tnode_Type (ON_Boolean_Type); 845 subtype O_Cnode_Boolean_Lit is O_Cnode_Type (OC_Boolean_Lit); 846 begin 847 Res := new O_Tnode_Boolean'(Kind => ON_Boolean_Type, 848 Decl => O_Dnode_Null, 849 Uncomplete => False, 850 Complete => True, 851 Constrained => True, 852 True_N => O_Cnode_Null, 853 False_N => O_Cnode_Null); 854 True_E := new O_Cnode_Boolean_Lit'(Kind => OC_Boolean_Lit, 855 Ctype => Res, 856 Ref => False, 857 B_Val => True, 858 B_Id => True_Id); 859 False_E := new O_Cnode_Boolean_Lit'(Kind => OC_Boolean_Lit, 860 Ctype => Res, 861 Ref => False, 862 B_Val => False, 863 B_Id => False_Id); 864 Res.True_N := True_E; 865 Res.False_N := False_E; 866 end New_Boolean_Type; 867 868 procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) 869 is 870 pragma Unreferenced (Size); 871 subtype O_Tnode_Enum is O_Tnode_Type (ON_Enum_Type); 872 Res : O_Tnode; 873 begin 874 Res := new O_Tnode_Enum'(Kind => ON_Enum_Type, 875 Decl => O_Dnode_Null, 876 Uncomplete => False, 877 Complete => False, 878 Constrained => True, 879 Nbr => 0, 880 Literals => O_Cnode_Null); 881 List.Res := Res; 882 List.Last := O_Cnode_Null; 883 end Start_Enum_Type; 884 885 procedure New_Enum_Literal (List : in out O_Enum_List; 886 Ident : O_Ident; 887 Res : out O_Cnode) 888 is 889 subtype O_Cnode_Enum_Lit is O_Cnode_Type (OC_Enum_Lit); 890 begin 891 Res := new O_Cnode_Enum_Lit'(Kind => OC_Enum_Lit, 892 Ctype => List.Res, 893 Ref => False, 894 E_Val => List.Res.Nbr, 895 E_Name => Ident, 896 E_Next => O_Cnode_Null); 897 -- Link it. 898 if List.Last = O_Cnode_Null then 899 List.Res.Literals := Res; 900 else 901 List.Last.E_Next := Res; 902 end if; 903 List.Last := Res; 904 905 List.Res.Nbr := List.Res.Nbr + 1; 906 end New_Enum_Literal; 907 908 procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is 909 begin 910 Res := List.Res; 911 Res.Complete := True; 912 end Finish_Enum_Type; 913 914 function Get_Array_El_Type (Atype : O_Tnode) return O_Tnode is 915 begin 916 case Atype.Kind is 917 when ON_Array_Subtype => 918 return Atype.Arr_El_Type; 919 when ON_Array_Type => 920 return Atype.El_Type; 921 when others => 922 raise Syntax_Error; 923 end case; 924 end Get_Array_El_Type; 925 926 procedure Start_Record_Aggr (List : out O_Record_Aggr_List; Atype : O_Tnode) 927 is 928 subtype O_Cnode_Aggregate is O_Cnode_Type (OC_Record_Aggregate); 929 Res : O_Cnode; 930 begin 931 if Atype.Kind /= ON_Record_Type then 932 raise Type_Error; 933 end if; 934 Check_Complete_Type (Atype); 935 Res := new O_Cnode_Aggregate'(Kind => OC_Record_Aggregate, 936 Ctype => Atype, 937 Ref => False, 938 Rec_Els => null); 939 List.Res := Res; 940 List.Last := null; 941 List.Field := Atype.Rec_Elements; 942 end Start_Record_Aggr; 943 944 procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; 945 Value : O_Cnode) 946 is 947 subtype O_Cnode_Aggrel_Type is O_Cnode_Type (OC_Aggr_Element); 948 El : O_Cnode; 949 begin 950 if List.Field = O_Fnode_Null then 951 -- No more element in the aggregate. 952 raise Syntax_Error; 953 end if; 954 Check_Type (Value.Ctype, List.Field.Ftype); 955 El := new O_Cnode_Aggrel_Type'(Kind => OC_Aggr_Element, 956 Ctype => Value.Ctype, 957 Ref => False, 958 Aggr_Value => Value, 959 Aggr_Next => null); 960 if List.Last = null then 961 List.Res.Rec_Els := El; 962 else 963 List.Last.Aggr_Next := El; 964 end if; 965 List.Last := El; 966 List.Field := List.Field.Next; 967 end New_Record_Aggr_El; 968 969 procedure Finish_Record_Aggr 970 (List : in out O_Record_Aggr_List; Res : out O_Cnode) 971 is 972 begin 973 if List.Field /= null then 974 -- Not enough elements in aggregate. 975 raise Type_Error; 976 end if; 977 Res := List.Res; 978 end Finish_Record_Aggr; 979 980 procedure Start_Array_Aggr 981 (List : out O_Array_Aggr_List; Atype : O_Tnode; Len : Unsigned_32) 982 is 983 subtype O_Cnode_Aggregate is O_Cnode_Type (OC_Array_Aggregate); 984 Res : O_Cnode; 985 begin 986 case Atype.Kind is 987 when ON_Array_Subtype => 988 if Atype.Length.U_Val /= Unsigned_64 (Len) then 989 raise Type_Error; 990 end if; 991 when ON_Array_Type => 992 null; 993 when others => 994 raise Type_Error; 995 end case; 996 List.El_Type := Get_Array_El_Type (Atype); 997 Check_Complete_Type (Atype); 998 Res := new O_Cnode_Aggregate'(Kind => OC_Array_Aggregate, 999 Ctype => Atype, 1000 Ref => False, 1001 Arr_Len => Len, 1002 Arr_Els => null); 1003 List.Res := Res; 1004 List.Last := null; 1005 end Start_Array_Aggr; 1006 1007 procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; 1008 Value : O_Cnode) 1009 is 1010 subtype O_Cnode_Aggrel_Type is O_Cnode_Type (OC_Aggr_Element); 1011 El : O_Cnode; 1012 begin 1013 Check_Type (Value.Ctype, List.El_Type); 1014 El := new O_Cnode_Aggrel_Type'(Kind => OC_Aggr_Element, 1015 Ctype => Value.Ctype, 1016 Ref => False, 1017 Aggr_Value => Value, 1018 Aggr_Next => null); 1019 if List.Last = null then 1020 List.Res.Arr_Els := El; 1021 else 1022 List.Last.Aggr_Next := El; 1023 end if; 1024 List.Last := El; 1025 end New_Array_Aggr_El; 1026 1027 procedure Finish_Array_Aggr 1028 (List : in out O_Array_Aggr_List; Res : out O_Cnode) is 1029 begin 1030 Res := List.Res; 1031 end Finish_Array_Aggr; 1032 1033 function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) 1034 return O_Cnode 1035 is 1036 subtype O_Cnode_Union_Aggr is O_Cnode_Type (OC_Union_Aggr); 1037 Res : O_Cnode; 1038 begin 1039 if Atype.Kind /= ON_Union_Type then 1040 raise Type_Error; 1041 end if; 1042 Check_Type (Value.Ctype, Field.Ftype); 1043 1044 Res := new O_Cnode_Union_Aggr'(Kind => OC_Union_Aggr, 1045 Ctype => Atype, 1046 Ref => False, 1047 Uaggr_Field => Field, 1048 Uaggr_Value => Value); 1049 return Res; 1050 end New_Union_Aggr; 1051 1052 function New_Obj (Obj : O_Dnode) return O_Lnode 1053 is 1054 subtype O_Lnode_Obj is O_Lnode_Type (OL_Obj); 1055 begin 1056 case Obj.Kind is 1057 when ON_Const_Decl 1058 | ON_Var_Decl 1059 | ON_Interface_Decl => 1060 null; 1061 when others => 1062 raise Syntax_Error; 1063 end case; 1064 Check_Scope (Obj); 1065 return new O_Lnode_Obj'(Kind => OL_Obj, 1066 Rtype => Obj.Dtype, 1067 Ref => False, 1068 Obj => Obj); 1069 end New_Obj; 1070 1071 function New_Global (Decl : O_Dnode) return O_Gnode 1072 is 1073 subtype O_Gnode_Decl is O_Gnode_Type (OG_Decl); 1074 begin 1075 case Decl.Kind is 1076 when ON_Const_Decl 1077 | ON_Var_Decl => 1078 null; 1079 when others => 1080 raise Syntax_Error; 1081 end case; 1082 if Decl.Storage = O_Storage_Local then 1083 raise Syntax_Error; 1084 end if; 1085 return new O_Gnode_Decl'(Kind => OG_Decl, 1086 Rtype => Decl.Dtype, 1087 Ref => False, 1088 Decl => Decl); 1089 end New_Global; 1090 1091 function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) 1092 return O_Lnode 1093 is 1094 subtype O_Lnode_Indexed is O_Lnode_Type (OL_Indexed_Element); 1095 El_Type : O_Tnode; 1096 Res : O_Lnode; 1097 begin 1098 if Arr.Rtype.Kind not in ON_Array_Kinds then 1099 -- Can only index an array. 1100 raise Type_Error; 1101 end if; 1102 -- The element type of ARR must be constrained. 1103 El_Type := Get_Array_El_Type (Arr.Rtype); 1104 Check_Constrained_Type (El_Type); 1105 Check_Ref (Arr); 1106 Res := new O_Lnode_Indexed'(Kind => OL_Indexed_Element, 1107 Rtype => El_Type, 1108 Ref => False, 1109 Array_Base => Arr, 1110 Index => Index); 1111 return Res; 1112 end New_Indexed_Element; 1113 1114 function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) 1115 return O_Lnode 1116 is 1117 subtype O_Lnode_Slice is O_Lnode_Type (OL_Slice); 1118 Res : O_Lnode; 1119 begin 1120 if Arr.Rtype.Kind not in ON_Array_Kinds then 1121 -- Can only slice an array. 1122 raise Type_Error; 1123 end if; 1124 -- The element type of ARR must be constrained. 1125 Check_Constrained_Type (Get_Array_El_Type (Arr.Rtype)); 1126 -- The result is an array. 1127 if Res_Type.Kind not in ON_Array_Kinds then 1128 raise Type_Error; 1129 end if; 1130 Check_Ref (Arr); 1131 Check_Ref (Index); 1132 -- FIXME: check type. 1133 Res := new O_Lnode_Slice'(Kind => OL_Slice, 1134 Rtype => Res_Type, 1135 Ref => False, 1136 Slice_Base => Arr, 1137 Slice_Index => Index); 1138 return Res; 1139 end New_Slice; 1140 1141 function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) 1142 return O_Lnode 1143 is 1144 subtype O_Lnode_Selected_Element is O_Lnode_Type (OL_Selected_Element); 1145 begin 1146 case Rec.Rtype.Kind is 1147 when ON_Record_Type 1148 | ON_Record_Subtype 1149 | ON_Union_Type => 1150 null; 1151 when others => 1152 raise Type_Error; 1153 end case; 1154 if Rec.Rtype /= El.Parent then 1155 raise Type_Error; 1156 end if; 1157 Check_Ref (Rec); 1158 return new O_Lnode_Selected_Element'(Kind => OL_Selected_Element, 1159 Rtype => El.Ftype, 1160 Ref => False, 1161 Rec_Base => Rec, 1162 Rec_El => El); 1163 end New_Selected_Element; 1164 1165 function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode) 1166 return O_Gnode 1167 is 1168 subtype O_Gnode_Selected_Element is O_Gnode_Type (OG_Selected_Element); 1169 begin 1170 if Rec.Rtype.Kind /= ON_Record_Type 1171 and then Rec.Rtype.Kind /= ON_Union_Type 1172 then 1173 raise Type_Error; 1174 end if; 1175 if Rec.Rtype /= El.Parent then 1176 raise Type_Error; 1177 end if; 1178 Check_Ref (Rec); 1179 return new O_Gnode_Selected_Element'(Kind => OG_Selected_Element, 1180 Rtype => El.Ftype, 1181 Ref => False, 1182 Rec_Base => Rec, 1183 Rec_El => El); 1184 end New_Global_Selected_Element; 1185 1186 function New_Access_Element (Acc : O_Enode) return O_Lnode 1187 is 1188 subtype O_Lnode_Access_Element is O_Lnode_Type (OL_Access_Element); 1189 begin 1190 if Acc.Rtype.Kind /= ON_Access_Type then 1191 raise Type_Error; 1192 end if; 1193 Check_Ref (Acc); 1194 return new O_Lnode_Access_Element'(Kind => OL_Access_Element, 1195 Rtype => Acc.Rtype.D_Type, 1196 Ref => False, 1197 Acc_Base => Acc); 1198 end New_Access_Element; 1199 1200 function Check_Conv (Source : ON_Type_Kind; Target : ON_Type_Kind) 1201 return Boolean 1202 is 1203 type Conv_Array is array (ON_Type_Kind, ON_Type_Kind) of Boolean; 1204 T : constant Boolean := True; 1205 F : constant Boolean := False; 1206 Conv_Allowed : constant Conv_Array := 1207 -- B E U S F A a R r U A 1208 (ON_Boolean_Type => (T, F, T, T, F, F, F, F, F, F, F), 1209 ON_Enum_Type => (F, F, T, T, F, F, F, F, F, F, F), 1210 ON_Unsigned_Type => (T, T, T, T, F, F, F, F, F, F, F), 1211 ON_Signed_Type => (T, T, T, T, T, F, F, F, F, F, F), 1212 ON_Float_Type => (F, F, F, T, T, F, F, F, F, F, F), 1213 ON_Array_Type => (F, F, F, F, F, F, F, F, F, F, F), 1214 ON_Array_Subtype => (F, F, F, F, F, F, F, F, F, F, F), 1215 ON_Record_Type => (F, F, F, F, F, F, F, F, F, F, F), 1216 ON_Record_Subtype => (F, F, F, F, F, F, F, F, F, F, F), 1217 ON_Union_Type => (F, F, F, F, F, F, F, F, F, F, F), 1218 ON_Access_Type => (F, F, F, F, F, F, F, F, F, F, T)); 1219 begin 1220 if Source = Target then 1221 return True; 1222 else 1223 return Conv_Allowed (Source, Target); 1224 end if; 1225 end Check_Conv; 1226 1227 function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode 1228 is 1229 Res : O_Enode; 1230 begin 1231 Check_Ref (Val); 1232 if not Check_Conv (Val.Rtype.Kind, Rtype.Kind) then 1233 raise Type_Error; 1234 end if; 1235 Res := new O_Enode_Type'(Kind => OE_Convert_Ov, 1236 Rtype => Rtype, 1237 Ref => False, 1238 Conv => Val); 1239 return Res; 1240 end New_Convert_Ov; 1241 1242 function New_Convert (Val : O_Enode; Rtype : O_Tnode) return O_Enode 1243 is 1244 Res : O_Enode; 1245 begin 1246 Check_Ref (Val); 1247 if not Check_Conv (Val.Rtype.Kind, Rtype.Kind) then 1248 raise Type_Error; 1249 end if; 1250 Res := new O_Enode_Type'(Kind => OE_Convert, 1251 Rtype => Rtype, 1252 Ref => False, 1253 Conv => Val); 1254 return Res; 1255 end New_Convert; 1256 1257 function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) 1258 return O_Enode 1259 is 1260 subtype O_Enode_Address is O_Enode_Type (OE_Unchecked_Address); 1261 begin 1262 Check_Ref (Lvalue); 1263 if Atype.Kind /= ON_Access_Type then 1264 -- An address is of type access. 1265 raise Type_Error; 1266 end if; 1267 return new O_Enode_Address'(Kind => OE_Unchecked_Address, 1268 Rtype => Atype, 1269 Ref => False, 1270 Lvalue => Lvalue); 1271 end New_Unchecked_Address; 1272 1273 function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode 1274 is 1275 subtype O_Enode_Address is O_Enode_Type (OE_Address); 1276 begin 1277 Check_Ref (Lvalue); 1278 if Atype.Kind /= ON_Access_Type then 1279 -- An address is of type access. 1280 raise Type_Error; 1281 end if; 1282 Check_Type (Get_Base_Type (Lvalue.Rtype), Get_Base_Type (Atype.D_Type)); 1283 return new O_Enode_Address'(Kind => OE_Address, 1284 Rtype => Atype, 1285 Ref => False, 1286 Lvalue => Lvalue); 1287 end New_Address; 1288 1289 function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode) 1290 return O_Cnode 1291 is 1292 subtype O_Cnode_Address is O_Cnode_Type (OC_Unchecked_Address); 1293 begin 1294 -- FIXME: check Lvalue is a static object. 1295 Check_Ref (Lvalue); 1296 if Atype.Kind /= ON_Access_Type then 1297 -- An address is of type access. 1298 raise Type_Error; 1299 end if; 1300 return new O_Cnode_Address'(Kind => OC_Unchecked_Address, 1301 Ctype => Atype, 1302 Ref => False, 1303 Addr_Global => Lvalue); 1304 end New_Global_Unchecked_Address; 1305 1306 function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode) 1307 return O_Cnode 1308 is 1309 subtype O_Cnode_Address is O_Cnode_Type (OC_Address); 1310 begin 1311 -- FIXME: check Lvalue is a static object. 1312 Check_Ref (Lvalue); 1313 if Atype.Kind /= ON_Access_Type then 1314 -- An address is of type access. 1315 raise Type_Error; 1316 end if; 1317 if Get_Base_Type (Lvalue.Rtype) /= Get_Base_Type (Atype.D_Type) then 1318 raise Type_Error; 1319 end if; 1320 return new O_Cnode_Address'(Kind => OC_Address, 1321 Ctype => Atype, 1322 Ref => False, 1323 Addr_Global => Lvalue); 1324 end New_Global_Address; 1325 1326 function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) 1327 return O_Cnode 1328 is 1329 subtype O_Cnode_Subprg_Address is O_Cnode_Type (OC_Subprogram_Address); 1330 begin 1331 if Atype.Kind /= ON_Access_Type then 1332 -- An address is of type access. 1333 raise Type_Error; 1334 end if; 1335 return new O_Cnode_Subprg_Address'(Kind => OC_Subprogram_Address, 1336 Ctype => Atype, 1337 Ref => False, 1338 Addr_Decl => Subprg); 1339 end New_Subprogram_Address; 1340 1341 -- Raise TYPE_ERROR is ATYPE is a composite type. 1342 procedure Check_Not_Composite (Atype : O_Tnode) is 1343 begin 1344 case Atype.Kind is 1345 when ON_Boolean_Type 1346 | ON_Unsigned_Type 1347 | ON_Signed_Type 1348 | ON_Float_Type 1349 | ON_Enum_Type 1350 | ON_Access_Type=> 1351 return; 1352 when ON_Array_Type 1353 | ON_Record_Type 1354 | ON_Record_Subtype 1355 | ON_Union_Type 1356 | ON_Array_Subtype => 1357 raise Type_Error; 1358 end case; 1359 end Check_Not_Composite; 1360 1361 function New_Value (Lvalue : O_Lnode) return O_Enode is 1362 subtype O_Enode_Value is O_Enode_Type (OE_Value); 1363 begin 1364 Check_Not_Composite (Lvalue.Rtype); 1365 Check_Ref (Lvalue); 1366 return new O_Enode_Value'(Kind => OE_Value, 1367 Rtype => Lvalue.Rtype, 1368 Ref => False, 1369 Value => Lvalue); 1370 end New_Value; 1371 1372 function New_Obj_Value (Obj : O_Dnode) return O_Enode is 1373 begin 1374 return New_Value (New_Obj (Obj)); 1375 end New_Obj_Value; 1376 1377 function New_Lit (Lit : O_Cnode) return O_Enode is 1378 subtype O_Enode_Lit is O_Enode_Type (OE_Lit); 1379 begin 1380 Check_Not_Composite (Lit.Ctype); 1381 return new O_Enode_Lit'(Kind => OE_Lit, 1382 Rtype => Lit.Ctype, 1383 Ref => False, 1384 Lit => Lit); 1385 end New_Lit; 1386 1387 --------------------- 1388 -- Declarations. -- 1389 --------------------- 1390 1391 procedure New_Debug_Filename_Decl (Filename : String) 1392 is 1393 subtype O_Dnode_Filename_Decl is O_Dnode_Type (ON_Debug_Filename_Decl); 1394 N : O_Dnode; 1395 begin 1396 N := new O_Dnode_Filename_Decl; 1397 N.Filename := new String'(Filename); 1398 Add_Decl (N, False); 1399 end New_Debug_Filename_Decl; 1400 1401 procedure New_Debug_Line_Decl (Line : Natural) 1402 is 1403 subtype O_Dnode_Line_Decl is O_Dnode_Type (ON_Debug_Line_Decl); 1404 N : O_Dnode; 1405 begin 1406 N := new O_Dnode_Line_Decl; 1407 N.Line := Line; 1408 Add_Decl (N, False); 1409 end New_Debug_Line_Decl; 1410 1411 procedure New_Debug_Comment_Decl (Comment : String) 1412 is 1413 subtype O_Dnode_Comment_Decl is O_Dnode_Type (ON_Debug_Comment_Decl); 1414 N : O_Dnode; 1415 begin 1416 N := new O_Dnode_Comment_Decl; 1417 N.Comment := new String'(Comment); 1418 Add_Decl (N, False); 1419 end New_Debug_Comment_Decl; 1420 1421 procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) 1422 is 1423 N : O_Dnode; 1424 begin 1425 if Atype.Decl /= null then 1426 -- Type was already declared. 1427 raise Type_Error; 1428 end if; 1429 N := new O_Dnode_Type (ON_Type_Decl); 1430 N.Name := Ident; 1431 N.Dtype := Atype; 1432 Atype.Decl := N; 1433 Add_Decl (N); 1434 end New_Type_Decl; 1435 1436 procedure Check_Object_Storage (Storage : O_Storage) is 1437 begin 1438 if Current_Function /= null then 1439 -- Inside a subprogram. 1440 case Storage is 1441 when O_Storage_Public => 1442 -- Cannot create public variables inside a subprogram. 1443 raise Syntax_Error; 1444 when O_Storage_Private 1445 | O_Storage_Local 1446 | O_Storage_External => 1447 null; 1448 end case; 1449 else 1450 -- Global scope. 1451 case Storage is 1452 when O_Storage_Public 1453 | O_Storage_Private 1454 | O_Storage_External => 1455 null; 1456 when O_Storage_Local => 1457 -- Cannot create a local variables outside a subprogram. 1458 raise Syntax_Error; 1459 end case; 1460 end if; 1461 end Check_Object_Storage; 1462 1463 procedure New_Const_Decl 1464 (Res : out O_Dnode; 1465 Ident : O_Ident; 1466 Storage : O_Storage; 1467 Atype : O_Tnode) 1468 is 1469 subtype O_Dnode_Const is O_Dnode_Type (ON_Const_Decl); 1470 begin 1471 Check_Complete_Type (Atype); 1472 Check_Constrained_Type (Atype); 1473 if Storage = O_Storage_Local then 1474 -- A constant cannot be local. 1475 raise Syntax_Error; 1476 end if; 1477 Check_Object_Storage (Storage); 1478 Res := new O_Dnode_Const'(Kind => ON_Const_Decl, 1479 Name => Ident, 1480 Next => null, 1481 Dtype => Atype, 1482 Storage => Storage, 1483 Scope => Current_Decl_Scope.Parent, 1484 Lineno => 0, 1485 Value_Decl => O_Dnode_Null); 1486 Add_Decl (Res); 1487 end New_Const_Decl; 1488 1489 procedure Start_Init_Value (Decl : in out O_Dnode) 1490 is 1491 subtype O_Dnode_Init_Value is O_Dnode_Type (ON_Init_Value); 1492 N : O_Dnode; 1493 begin 1494 if Decl.Value_Decl /= O_Dnode_Null then 1495 -- Constant already has a value. 1496 raise Syntax_Error; 1497 end if; 1498 1499 if Decl.Storage = O_Storage_External then 1500 -- An external variable/constant cannot have a value. 1501 raise Syntax_Error; 1502 end if; 1503 1504 -- FIXME: check scope is the same. 1505 1506 N := new O_Dnode_Init_Value'(Kind => ON_Init_Value, 1507 Name => Decl.Name, 1508 Next => null, 1509 Dtype => Decl.Dtype, 1510 Storage => Decl.Storage, 1511 Scope => Current_Decl_Scope.Parent, 1512 Lineno => 0, 1513 Init_Decl => Decl, 1514 Value => O_Cnode_Null); 1515 Decl.Value_Decl := N; 1516 Add_Decl (N, False); 1517 end Start_Init_Value; 1518 1519 procedure Finish_Init_Value (Decl : in out O_Dnode; Val : O_Cnode) is 1520 begin 1521 if Decl.Value_Decl = O_Dnode_Null then 1522 -- Start_Init_Value not called. 1523 raise Syntax_Error; 1524 end if; 1525 if Decl.Value_Decl.Value /= O_Cnode_Null then 1526 -- Finish_Init_Value already called. 1527 raise Syntax_Error; 1528 end if; 1529 if Val = O_Cnode_Null then 1530 -- No value or bad type. 1531 raise Type_Error; 1532 end if; 1533 Check_Type (Val.Ctype, Decl.Dtype); 1534 Decl.Value_Decl.Value := Val; 1535 end Finish_Init_Value; 1536 1537 procedure New_Var_Decl 1538 (Res : out O_Dnode; 1539 Ident : O_Ident; 1540 Storage : O_Storage; 1541 Atype : O_Tnode) 1542 is 1543 subtype O_Dnode_Var is O_Dnode_Type (ON_Var_Decl); 1544 begin 1545 Check_Complete_Type (Atype); 1546 Check_Constrained_Type (Atype); 1547 Check_Object_Storage (Storage); 1548 Res := new O_Dnode_Var'(Kind => ON_Var_Decl, 1549 Name => Ident, 1550 Next => null, 1551 Dtype => Atype, 1552 Storage => Storage, 1553 Lineno => 0, 1554 Scope => Current_Decl_Scope.Parent, 1555 Value_Decl => O_Dnode_Null); 1556 Add_Decl (Res); 1557 end New_Var_Decl; 1558 1559 procedure Start_Subprogram_Decl_1 1560 (Interfaces : out O_Inter_List; 1561 Ident : O_Ident; 1562 Storage : O_Storage; 1563 Rtype : O_Tnode) 1564 is 1565 subtype O_Dnode_Function is O_Dnode_Type (ON_Function_Decl); 1566 N : O_Dnode; 1567 begin 1568 N := new O_Dnode_Function'(Kind => ON_Function_Decl, 1569 Next => null, 1570 Name => Ident, 1571 Dtype => Rtype, 1572 Storage => Storage, 1573 Scope => Current_Decl_Scope.Parent, 1574 Lineno => 0, 1575 Interfaces => null, 1576 Func_Body => null, 1577 Alive => False); 1578 Add_Decl (N); 1579 Interfaces.Func := N; 1580 Interfaces.Last := null; 1581 end Start_Subprogram_Decl_1; 1582 1583 procedure Start_Function_Decl 1584 (Interfaces : out O_Inter_List; 1585 Ident : O_Ident; 1586 Storage : O_Storage; 1587 Rtype : O_Tnode) 1588 is 1589 begin 1590 Check_Not_Composite (Rtype); 1591 Check_Complete_Type (Rtype); 1592 Start_Subprogram_Decl_1 (Interfaces, Ident, Storage, Rtype); 1593 end Start_Function_Decl; 1594 1595 procedure Start_Procedure_Decl 1596 (Interfaces : out O_Inter_List; 1597 Ident : O_Ident; 1598 Storage : O_Storage) is 1599 begin 1600 Start_Subprogram_Decl_1 (Interfaces, Ident, Storage, null); 1601 end Start_Procedure_Decl; 1602 1603 procedure New_Interface_Decl 1604 (Interfaces : in out O_Inter_List; 1605 Res : out O_Dnode; 1606 Ident : O_Ident; 1607 Atype : O_Tnode) 1608 is 1609 subtype O_Dnode_Interface is O_Dnode_Type (ON_Interface_Decl); 1610 begin 1611 Check_Not_Composite (Atype); 1612 Check_Complete_Type (Atype); 1613 Res := new O_Dnode_Interface'(Kind => ON_Interface_Decl, 1614 Next => null, 1615 Name => Ident, 1616 Dtype => Atype, 1617 Storage => O_Storage_Private, 1618 Scope => Current_Decl_Scope.Parent, 1619 Lineno => 0, 1620 Func_Scope => Interfaces.Func); 1621 if Interfaces.Last = null then 1622 Interfaces.Func.Interfaces := Res; 1623 else 1624 Interfaces.Last.Next := Res; 1625 end if; 1626 Interfaces.Last := Res; 1627 end New_Interface_Decl; 1628 1629 procedure Finish_Subprogram_Decl 1630 (Interfaces : in out O_Inter_List; Res : out O_Dnode) 1631 is 1632 begin 1633 Res := Interfaces.Func; 1634 end Finish_Subprogram_Decl; 1635 1636 procedure Start_Subprogram_Body (Func : O_Dnode) 1637 is 1638 B : O_Dnode; 1639 S : O_Snode; 1640 begin 1641 if Func.Func_Body /= null then 1642 -- Function was already declared. 1643 raise Syntax_Error; 1644 end if; 1645 S := new O_Snode_Type (ON_Declare_Stmt); 1646 S.all := O_Snode_Type'(Kind => ON_Declare_Stmt, 1647 Next => null, 1648 Decls => null, 1649 Stmts => null, 1650 Lineno => 0, 1651 Alive => True); 1652 B := new O_Dnode_Type (ON_Function_Body); 1653 B.all := O_Dnode_Type'(ON_Function_Body, 1654 Name => Func.Name, 1655 Dtype => Func.Dtype, 1656 Storage => Func.Storage, 1657 Scope => Current_Decl_Scope.Parent, 1658 Lineno => 0, 1659 Func_Decl => Func, 1660 Func_Stmt => S, 1661 Next => null); 1662 Add_Decl (B, False); 1663 Func.Func_Body := B; 1664 Push_Decl_Scope (S); 1665 Push_Stmt_Scope 1666 (new Stmt_Function_Scope_Type'(Kind => Stmt_Function, 1667 Parent => S, 1668 Prev => Current_Stmt_Scope, 1669 Prev_Function => Current_Function, 1670 Decl => Func)); 1671 Current_Function := Current_Stmt_Scope; 1672 Func.Alive := True; 1673 end Start_Subprogram_Body; 1674 1675 procedure Finish_Subprogram_Body is 1676 begin 1677 Pop_Decl_Scope; 1678 if Current_Function.Kind /= Stmt_Function then 1679 -- Internal error. 1680 raise Syntax_Error; 1681 end if; 1682 Current_Function.Decl.Alive := False; 1683 Current_Function := Current_Function.Prev_Function; 1684 Pop_Stmt_Scope (Stmt_Function); 1685 end Finish_Subprogram_Body; 1686 1687 ------------------- 1688 -- Statements. -- 1689 ------------------- 1690 1691 procedure New_Debug_Line_Stmt (Line : Natural) 1692 is 1693 subtype O_Snode_Line_Stmt is O_Snode_Type (ON_Debug_Line_Stmt); 1694 begin 1695 Add_Stmt (new O_Snode_Line_Stmt'(Kind => ON_Debug_Line_Stmt, 1696 Next => null, 1697 Lineno => 0, 1698 Line => Line)); 1699 end New_Debug_Line_Stmt; 1700 1701 procedure New_Debug_Comment_Stmt (Comment : String) 1702 is 1703 subtype O_Snode_Comment_Stmt is O_Snode_Type (ON_Debug_Comment_Stmt); 1704 begin 1705 Add_Stmt (new O_Snode_Comment_Stmt'(Kind => ON_Debug_Comment_Stmt, 1706 Next => null, 1707 Lineno => 0, 1708 Comment => new String'(Comment))); 1709 end New_Debug_Comment_Stmt; 1710 1711 procedure Start_Declare_Stmt 1712 is 1713 N : O_Snode; 1714 begin 1715 N := new O_Snode_Type (ON_Declare_Stmt); 1716 Add_Stmt (N); 1717 Push_Decl_Scope (N); 1718 Push_Stmt_Scope 1719 (new Stmt_Declare_Scope_Type'(Kind => Stmt_Declare, 1720 Parent => N, 1721 Prev => Current_Stmt_Scope)); 1722 end Start_Declare_Stmt; 1723 1724 procedure Finish_Declare_Stmt is 1725 begin 1726 Pop_Decl_Scope; 1727 Pop_Stmt_Scope (Stmt_Declare); 1728 end Finish_Declare_Stmt; 1729 1730 procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) 1731 is 1732 N : O_Snode; 1733 begin 1734 Check_Type (Target.Rtype, Value.Rtype); 1735 Check_Not_Composite (Target.Rtype); 1736 Check_Ref (Target); 1737 Check_Ref (Value); 1738 N := new O_Snode_Type (ON_Assign_Stmt); 1739 N.all := O_Snode_Type'(Kind => ON_Assign_Stmt, 1740 Next => null, 1741 Lineno => 0, 1742 Target => Target, 1743 Value => Value); 1744 Add_Stmt (N); 1745 end New_Assign_Stmt; 1746 1747 procedure New_Return_Stmt_1 (Value : O_Enode) 1748 is 1749 subtype O_Snode_Return_Stmt is O_Snode_Type (ON_Return_Stmt); 1750 N : O_Snode; 1751 begin 1752 N := new O_Snode_Return_Stmt'(Kind => ON_Return_Stmt, 1753 Next => null, 1754 Lineno => 0, 1755 Ret_Val => Value); 1756 Add_Stmt (N); 1757 end New_Return_Stmt_1; 1758 1759 procedure New_Return_Stmt (Value : O_Enode) 1760 is 1761 begin 1762 if Current_Function = null 1763 or else Current_Function.Decl.Dtype = O_Tnode_Null 1764 then 1765 -- Either not in a function or in a procedure. 1766 raise Syntax_Error; 1767 end if; 1768 Check_Type (Value.Rtype, Current_Function.Decl.Dtype); 1769 Check_Ref (Value); 1770 New_Return_Stmt_1 (Value); 1771 end New_Return_Stmt; 1772 1773 procedure New_Return_Stmt is 1774 begin 1775 if Current_Function = null 1776 or else Current_Function.Decl.Dtype /= O_Tnode_Null 1777 then 1778 -- Not in a procedure. 1779 raise Syntax_Error; 1780 end if; 1781 New_Return_Stmt_1 (null); 1782 end New_Return_Stmt; 1783 1784 procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) 1785 is 1786 begin 1787 Check_Scope (Subprg); 1788 Assocs.Subprg := Subprg; 1789 Assocs.Interfaces := Subprg.Interfaces; 1790 Assocs.First := null; 1791 Assocs.Last := null; 1792 end Start_Association; 1793 1794 procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) 1795 is 1796 N : O_Anode; 1797 begin 1798 if Assocs.Interfaces = null then 1799 -- Too many arguments. 1800 raise Syntax_Error; 1801 end if; 1802 Check_Type (Assocs.Interfaces.Dtype, Val.Rtype); 1803 Check_Ref (Val); 1804 N := new O_Anode_Type'(Next => null, 1805 Formal => Assocs.Interfaces, Actual => Val); 1806 Assocs.Interfaces := Assocs.Interfaces.Next; 1807 if Assocs.Last = null then 1808 Assocs.First := N; 1809 else 1810 Assocs.Last.Next := N; 1811 end if; 1812 Assocs.Last := N; 1813 end New_Association; 1814 1815 function New_Function_Call (Assocs : O_Assoc_List) return O_Enode 1816 is 1817 subtype O_Enode_Call is O_Enode_Type (OE_Function_Call); 1818 Res : O_Enode; 1819 begin 1820 if Assocs.Interfaces /= null then 1821 -- Not enough arguments. 1822 raise Syntax_Error; 1823 end if; 1824 if Assocs.Subprg.Dtype = null then 1825 -- This is a procedure. 1826 raise Syntax_Error; 1827 end if; 1828 1829 Res := new O_Enode_Call'(Kind => OE_Function_Call, 1830 Rtype => Assocs.Subprg.Dtype, 1831 Ref => False, 1832 Func => Assocs.Subprg, 1833 Assoc => Assocs.First); 1834 return Res; 1835 end New_Function_Call; 1836 1837 procedure New_Procedure_Call (Assocs : in out O_Assoc_List) 1838 is 1839 N : O_Snode; 1840 begin 1841 if Assocs.Interfaces /= null then 1842 -- Not enough arguments. 1843 raise Syntax_Error; 1844 end if; 1845 if Assocs.Subprg.Dtype /= null then 1846 -- This is a function. 1847 raise Syntax_Error; 1848 end if; 1849 N := new O_Snode_Type (ON_Call_Stmt); 1850 N.Proc := Assocs.Subprg; 1851 N.Assoc := Assocs.First; 1852 Add_Stmt (N); 1853 end New_Procedure_Call; 1854 1855 procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode); 1856 1857 procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) 1858 is 1859 subtype O_Snode_If is O_Snode_Type (ON_If_Stmt); 1860 N : O_Snode; 1861 begin 1862 -- Note: no checks are performed here, since they are done in 1863 -- new_elsif_stmt. 1864 N := new O_Snode_If'(Kind => ON_If_Stmt, 1865 Next => null, 1866 Lineno => 0, 1867 Elsifs => null, 1868 If_Last => null); 1869 Add_Stmt (N); 1870 Push_Stmt_Scope (new Stmt_If_Scope_Type'(Kind => Stmt_If, 1871 Parent => N, 1872 Prev => Current_Stmt_Scope, 1873 Last_Elsif => null)); 1874 New_Elsif_Stmt (Block, Cond); 1875 end Start_If_Stmt; 1876 1877 procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode) 1878 is 1879 pragma Unreferenced (Block); 1880 N : O_Snode; 1881 begin 1882 if Cond /= null then 1883 if Cond.Rtype.Kind /= ON_Boolean_Type then 1884 raise Type_Error; 1885 end if; 1886 Check_Ref (Cond); 1887 end if; 1888 N := new O_Snode_Type (ON_Elsif_Stmt); 1889 N.all := O_Snode_Type'(Kind => ON_Elsif_Stmt, 1890 Next => null, 1891 Lineno => 0, 1892 Cond => Cond, 1893 Next_Elsif => null); 1894 if Current_Stmt_Scope.Kind /= Stmt_If then 1895 raise Syntax_Error; 1896 end if; 1897 Add_Stmt (N); 1898 if Current_Stmt_Scope.Last_Elsif = null then 1899 Current_Stmt_Scope.Parent.Elsifs := N; 1900 else 1901 -- Check for double 'else' 1902 if Current_Stmt_Scope.Last_Elsif.Cond = null then 1903 raise Syntax_Error; 1904 end if; 1905 Current_Stmt_Scope.Last_Elsif.Next_Elsif := N; 1906 end if; 1907 Current_Stmt_Scope.Last_Elsif := N; 1908 end New_Elsif_Stmt; 1909 1910 procedure New_Else_Stmt (Block : in out O_If_Block) is 1911 begin 1912 New_Elsif_Stmt (Block, null); 1913 end New_Else_Stmt; 1914 1915 procedure Finish_If_Stmt (Block : in out O_If_Block) 1916 is 1917 pragma Unreferenced (Block); 1918 Parent : O_Snode; 1919 begin 1920 Parent := Current_Stmt_Scope.Parent; 1921 Pop_Stmt_Scope (Stmt_If); 1922 Parent.If_Last := Current_Decl_Scope.Last_Stmt; 1923 end Finish_If_Stmt; 1924 1925 procedure Start_Loop_Stmt (Label : out O_Snode) 1926 is 1927 subtype O_Snode_Loop_Type is O_Snode_Type (ON_Loop_Stmt); 1928 begin 1929 Current_Loop_Level := Current_Loop_Level + 1; 1930 Label := new O_Snode_Loop_Type'(Kind => ON_Loop_Stmt, 1931 Next => null, 1932 Lineno => 0, 1933 Loop_Last => null, 1934 Loop_Level => Current_Loop_Level); 1935 Add_Stmt (Label); 1936 Push_Stmt_Scope (new Stmt_Loop_Scope_Type'(Kind => Stmt_Loop, 1937 Parent => Label, 1938 Prev => Current_Stmt_Scope)); 1939 end Start_Loop_Stmt; 1940 1941 procedure Finish_Loop_Stmt (Label : in out O_Snode) 1942 is 1943 pragma Unreferenced (Label); 1944 Parent : O_Snode; 1945 begin 1946 Parent := Current_Stmt_Scope.Parent; 1947 Pop_Stmt_Scope (Stmt_Loop); 1948 Parent.Loop_Last := Current_Decl_Scope.Last_Stmt; 1949 Current_Loop_Level := Current_Loop_Level - 1; 1950 end Finish_Loop_Stmt; 1951 1952 procedure New_Exit_Next_Stmt (Kind : ON_Stmt_Kind; L : O_Snode) 1953 is 1954 N : O_Snode; 1955 begin 1956 N := new O_Snode_Type (Kind); 1957 N.Next := null; 1958 N.Loop_Id := L; 1959 Add_Stmt (N); 1960 end New_Exit_Next_Stmt; 1961 1962 procedure New_Exit_Stmt (L : O_Snode) is 1963 begin 1964 New_Exit_Next_Stmt (ON_Exit_Stmt, L); 1965 end New_Exit_Stmt; 1966 1967 procedure New_Next_Stmt (L : O_Snode) is 1968 begin 1969 New_Exit_Next_Stmt (ON_Next_Stmt, L); 1970 end New_Next_Stmt; 1971 1972 procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) 1973 is 1974 subtype O_Snode_Case_Type is O_Snode_Type (ON_Case_Stmt); 1975 N : O_Snode; 1976 begin 1977 case Value.Rtype.Kind is 1978 when ON_Boolean_Type 1979 | ON_Unsigned_Type 1980 | ON_Signed_Type 1981 | ON_Enum_Type => 1982 null; 1983 when others => 1984 raise Type_Error; 1985 end case; 1986 Check_Ref (Value); 1987 N := new O_Snode_Case_Type'(Kind => ON_Case_Stmt, 1988 Next => null, 1989 Lineno => 0, 1990 Case_Last => null, 1991 Selector => Value, 1992 Branches => null); 1993 Block.Case_Stmt := N; 1994 Add_Stmt (N); 1995 Push_Stmt_Scope (new Stmt_Case_Scope_Type'(Kind => Stmt_Case, 1996 Parent => N, 1997 Prev => Current_Stmt_Scope, 1998 Last_Branch => null, 1999 Last_Choice => null, 2000 Case_Type => Value.Rtype)); 2001 end Start_Case_Stmt; 2002 2003 procedure Start_Choice (Block : in out O_Case_Block) 2004 is 2005 N : O_Snode; 2006 begin 2007 if Current_Stmt_Scope.Kind /= Stmt_Case 2008 or else Current_Stmt_Scope.Parent /= Block.Case_Stmt 2009 then 2010 -- You are adding a branch outside a the case statment. 2011 raise Syntax_Error; 2012 end if; 2013 if Current_Stmt_Scope.Last_Choice /= null then 2014 -- You are creating branch while the previous one was not finished. 2015 raise Syntax_Error; 2016 end if; 2017 2018 N := new O_Snode_Type (ON_When_Stmt); 2019 N.all := O_Snode_Type'(Kind => ON_When_Stmt, 2020 Next => null, 2021 Lineno => 0, 2022 Branch_Parent => Block.Case_Stmt, 2023 Choice_List => null, 2024 Next_Branch => null); 2025 if Current_Stmt_Scope.Last_Branch = null then 2026 Current_Stmt_Scope.Parent.Branches := N; 2027 else 2028 Current_Stmt_Scope.Last_Branch.Next_Branch := N; 2029 end if; 2030 Current_Stmt_Scope.Last_Branch := N; 2031 Current_Stmt_Scope.Last_Choice := null; 2032 Add_Stmt (N); 2033 end Start_Choice; 2034 2035 procedure Add_Choice (Block : in out O_Case_Block; Choice : O_Choice) is 2036 begin 2037 if Current_Stmt_Scope.Kind /= Stmt_Case 2038 or else Current_Stmt_Scope.Parent /= Block.Case_Stmt 2039 then 2040 -- You are adding a branch outside a the case statment. 2041 raise Syntax_Error; 2042 end if; 2043 if Current_Stmt_Scope.Last_Branch = null then 2044 -- You are not inside a branch. 2045 raise Syntax_Error; 2046 end if; 2047 if Current_Stmt_Scope.Last_Choice = null then 2048 if Current_Stmt_Scope.Last_Branch.Choice_List /= null then 2049 -- The branch was already closed. 2050 raise Syntax_Error; 2051 end if; 2052 Current_Stmt_Scope.Last_Branch.Choice_List := Choice; 2053 else 2054 Current_Stmt_Scope.Last_Choice.Next := Choice; 2055 end if; 2056 Current_Stmt_Scope.Last_Choice := Choice; 2057 end Add_Choice; 2058 2059 procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) 2060 is 2061 N : O_Choice; 2062 begin 2063 if Current_Stmt_Scope.Kind /= Stmt_Case 2064 or else Current_Stmt_Scope.Parent /= Block.Case_Stmt 2065 then 2066 -- You are adding a branch outside a the case statment. 2067 raise Syntax_Error; 2068 end if; 2069 if Current_Stmt_Scope.Case_Type /= Expr.Ctype then 2070 -- Expr type is not the same as choice type. 2071 raise Type_Error; 2072 end if; 2073 2074 N := new O_Choice_Type (ON_Choice_Expr); 2075 N.all := O_Choice_Type'(Kind => ON_Choice_Expr, 2076 Next => null, 2077 Expr => Expr); 2078 Add_Choice (Block, N); 2079 end New_Expr_Choice; 2080 2081 procedure New_Range_Choice (Block : in out O_Case_Block; 2082 Low, High : O_Cnode) 2083 is 2084 N : O_Choice; 2085 begin 2086 if Current_Stmt_Scope.Kind /= Stmt_Case 2087 or else Current_Stmt_Scope.Parent /= Block.Case_Stmt 2088 then 2089 -- You are adding a branch outside a the case statment. 2090 raise Syntax_Error; 2091 end if; 2092 if Current_Stmt_Scope.Case_Type /= Low.Ctype 2093 or Current_Stmt_Scope.Case_Type /= High.Ctype 2094 then 2095 -- Low/High type is not the same as choice type. 2096 raise Type_Error; 2097 end if; 2098 2099 N := new O_Choice_Type (ON_Choice_Range); 2100 N.all := O_Choice_Type'(Kind => ON_Choice_Range, 2101 Next => null, 2102 Low => Low, 2103 High => High); 2104 Add_Choice (Block, N); 2105 end New_Range_Choice; 2106 2107 procedure New_Default_Choice (Block : in out O_Case_Block) 2108 is 2109 N : O_Choice; 2110 begin 2111 if Current_Stmt_Scope.Kind /= Stmt_Case 2112 or else Current_Stmt_Scope.Parent /= Block.Case_Stmt 2113 then 2114 -- You are adding a branch outside a the case statment. 2115 raise Syntax_Error; 2116 end if; 2117 2118 N := new O_Choice_Type (ON_Choice_Default); 2119 N.all := O_Choice_Type'(Kind => ON_Choice_Default, 2120 Next => null); 2121 Add_Choice (Block, N); 2122 end New_Default_Choice; 2123 2124 procedure Finish_Choice (Block : in out O_Case_Block) is 2125 begin 2126 if Current_Stmt_Scope.Kind /= Stmt_Case 2127 or else Current_Stmt_Scope.Parent /= Block.Case_Stmt 2128 then 2129 -- You are adding a branch outside a the case statment. 2130 raise Syntax_Error; 2131 end if; 2132 if Current_Stmt_Scope.Last_Branch = null then 2133 -- You are not inside a branch. 2134 raise Syntax_Error; 2135 end if; 2136 if Current_Stmt_Scope.Last_Choice = null then 2137 -- The branch is empty or you are not inside a branch. 2138 raise Syntax_Error; 2139 end if; 2140 Current_Stmt_Scope.Last_Choice := null; 2141 end Finish_Choice; 2142 2143 procedure Finish_Case_Stmt (Block : in out O_Case_Block) 2144 is 2145 Parent : O_Snode; 2146 begin 2147 if Current_Stmt_Scope.Kind /= Stmt_Case 2148 or else Current_Stmt_Scope.Parent /= Block.Case_Stmt 2149 then 2150 -- You are adding a branch outside a the case statment. 2151 raise Syntax_Error; 2152 end if; 2153 Parent := Current_Stmt_Scope.Parent; 2154 Pop_Stmt_Scope (Stmt_Case); 2155 Parent.Case_Last := Current_Decl_Scope.Last_Stmt; 2156 end Finish_Case_Stmt; 2157 2158 procedure Init is 2159 begin 2160 Top := new O_Snode_Type (ON_Declare_Stmt); 2161 Push_Decl_Scope (Top); 2162 end Init; 2163 2164 procedure Finish is 2165 begin 2166 Pop_Decl_Scope; 2167 end Finish; 2168end Ortho_Debug; 2169