1-- Ortho code compiler. 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>. 16with Ada.Unchecked_Deallocation; 17with Ortho_Nodes; use Ortho_Nodes; 18with Ortho_Ident; use Ortho_Ident; 19with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; 20with GNAT.OS_Lib; use GNAT.OS_Lib; 21with Interfaces; use Interfaces; 22with Ada.Exceptions; 23--with GNAT.Debug_Pools; 24 25-- TODO: 26-- uncomplete type: check for type redefinition 27 28package body Ortho_Front is 29 -- If true, emit line number before each statement. 30 -- If flase, keep line number indication in the source file. 31 Flag_Renumber : Boolean := True; 32 33 procedure Init is 34 begin 35 null; 36 end Init; 37 38 function Decode_Option (Opt : String_Acc; Arg : String_Acc) return Natural 39 is 40 pragma Unreferenced (Arg); 41 begin 42 if Opt.all = "-r" or Opt.all = "--ghdl-r" then 43 Flag_Renumber := True; 44 return 1; 45 else 46 return 0; 47 end if; 48 end Decode_Option; 49 50 -- File buffer. 51 File_Name : String_Acc; 52 Buf : String (1 .. 2048 + 1); 53 Buf_Len : Natural; 54 Pos : Natural; 55 Lineno : Natural; 56 57 Fd : File_Descriptor; 58 59 Error : exception; 60 61 procedure Puterr (Msg : String) 62 is 63 L : Integer; 64 pragma Unreferenced (L); 65 begin 66 L := Write (Standerr, Msg'Address, Msg'Length); 67 end Puterr; 68 69 procedure Puterr (N : Natural) 70 is 71 Str : constant String := Natural'Image (N); 72 begin 73 Puterr (Str (Str'First + 1 .. Str'Last)); 74 end Puterr; 75 76 procedure Newline_Err is 77 begin 78 Puterr ((1 => LF)); 79 end Newline_Err; 80 81 procedure Scan_Error (Msg : String) is 82 begin 83 Puterr (File_Name.all); 84 Puterr (":"); 85 Puterr (Lineno); 86 Puterr (": "); 87 Puterr (Msg); 88 Newline_Err; 89 raise Error; 90 end Scan_Error; 91 92 procedure Parse_Error (Msg : String); 93 pragma No_Return (Parse_Error); 94 95 procedure Parse_Error (Msg : String) is 96 begin 97 Puterr (File_Name.all); 98 Puterr (":"); 99 Puterr (Lineno); 100 Puterr (": "); 101 Puterr (Msg); 102 Newline_Err; 103 raise Error; 104 end Parse_Error; 105 106 107-- Uniq_Num : Natural := 0; 108 109-- function Get_Uniq_Id return O_Ident 110-- is 111-- Str : String (1 .. 8); 112-- V : Natural; 113-- begin 114-- V := Uniq_Num; 115-- Uniq_Num := Uniq_Num + 1; 116-- Str (1) := 'L'; 117-- Str (2) := '.'; 118-- for I in reverse 3 .. Str'Last loop 119-- Str (I) := Character'Val ((V mod 10) + Character'Pos('0')); 120-- V := V / 10; 121-- end loop; 122-- return Get_Identifier (Str); 123-- end Get_Uniq_Id; 124 125 -- Get the next character. 126 -- Return NUL on end of file. 127 function Get_Char return Character 128 is 129 Res : Character; 130 begin 131 if Buf (Pos) = NUL then 132 -- Read line. 133 Buf_Len := Read (Fd, Buf'Address, Buf'Length - 1); 134 if Buf_Len = 0 then 135 -- End of file. 136 return NUL; 137 end if; 138 Pos := 1; 139 Buf (Buf_Len + 1) := NUL; 140 end if; 141 142 Res := Buf (Pos); 143 Pos := Pos + 1; 144 return Res; 145 end Get_Char; 146 147 procedure Unget_Char is 148 begin 149 if Pos = Buf'First then 150 raise Program_Error; 151 end if; 152 Pos := Pos - 1; 153 end Unget_Char; 154 155 type Token_Type is 156 (Tok_Eof, 157 Tok_Line_Number, Tok_File_Name, Tok_Comment, 158 Tok_Ident, Tok_Num, Tok_String, Tok_Float_Num, 159 Tok_Plus, Tok_Minus, 160 Tok_Star, Tok_Div, Tok_Mod, Tok_Rem, 161 Tok_Sharp, 162 Tok_Not, Tok_Abs, 163 Tok_Or, Tok_And, Tok_Xor, 164 Tok_Equal, Tok_Not_Equal, 165 Tok_Greater, Tok_Greater_Eq, 166 Tok_Less, Tok_Less_Eq, 167 Tok_Colon, Tok_Semicolon, 168 Tok_Comma, Tok_Dot, Tok_Tick, Tok_Arob, Tok_Elipsis, 169 Tok_Assign, 170 Tok_Left_Paren, Tok_Right_Paren, 171 Tok_Left_Brace, Tok_Right_Brace, 172 Tok_Left_Brack, Tok_Right_Brack, 173 Tok_Unsigned, Tok_Signed, Tok_Float, 174 Tok_Array, Tok_Subarray, 175 Tok_Access, 176 Tok_Record, Tok_Subrecord, Tok_Union, 177 Tok_Boolean, Tok_Enum, 178 Tok_If, Tok_Then, Tok_Else, Tok_Elsif, 179 Tok_Loop, Tok_Exit, Tok_Next, 180 Tok_Is, Tok_Of, Tok_All, 181 Tok_Return, 182 Tok_Type, 183 Tok_External, Tok_Private, Tok_Public, Tok_Local, 184 Tok_Procedure, Tok_Function, 185 Tok_Constant, Tok_Var, 186 Tok_Declare, Tok_Begin, Tok_End, 187 Tok_Case, Tok_When, Tok_Default, Tok_Arrow, 188 Tok_Null); 189 190 type Hash_Type is new Unsigned_32; 191 192 type Name_Type; 193 type Name_Acc is access Name_Type; 194 195 -- Symbol table. 196 type Syment_Type; 197 type Syment_Acc is access Syment_Type; 198 type Syment_type is record 199 -- The hash for the symbol. 200 Hash : Hash_Type; 201 -- Identification of the symbol. 202 Ident : O_Ident; 203 -- Next symbol with the same collision. 204 Next : Syment_Acc; 205 -- Meaning of the symbol. 206 Name : Name_Acc; 207 end record; 208 209 -- Well known identifiers (used for attributes). 210 Id_Address : Syment_Acc; 211 Id_Unchecked_Address : Syment_Acc; 212 Id_Subprg_Addr : Syment_Acc; 213 Id_Conv : Syment_Acc; 214 Id_Sizeof : Syment_Acc; 215 Id_Record_Sizeof : Syment_Acc; 216 Id_Alignof : Syment_Acc; 217 Id_Alloca : Syment_Acc; 218 Id_Offsetof : Syment_Acc; 219 220 Token_Number : Unsigned_64; 221 Token_Float : IEEE_Float_64; 222 Token_Ident : String (1 .. 256); 223 Token_Idlen : Natural; 224 Token_Hash : Hash_Type; 225 Token_Sym : Syment_Acc; 226 227 -- The symbol table. 228 type Syment_Acc_Array is array (Hash_Type range <>) of Syment_Acc; 229 type Syment_Acc_Map (Max : Hash_Type) is record 230 Map : Syment_Acc_Array (0 .. Max); 231 end record; 232 type Syment_Acc_Map_Acc is access Syment_Acc_Map; 233 234 -- Prime numbers for the number of buckets in the hash map. 235 Hash_Primes : constant array (Natural range <>) of Hash_Type := 236 (389, 769, 1543, 3079, 6151, 12289, 24593, 49157, 98317, 196613, 237 393241, 786433, 1572869, 3145739, 6291469, 12582917, 25165843, 238 50331653, 100663319, 201326611, 402653189, 805306457, 1610612741); 239 240 -- Number of entries in the hash table. 241 Nbr_Syment : Natural := 0; 242 243 -- Maximum number of entries before resizing the hash table. 244 Max_Syment : Natural := 512; -- Could be less or more. 245 246 -- Current prime number in Hash_Primes. 247 Cur_Prime_Idx : Natural := 0; 248 249 Symtable : Syment_Acc_Map_Acc; 250 251 type Node_Kind is (Decl_Keyword, Decl_Type, Decl_Param, 252 Node_Function, Node_Procedure, Node_Object, Node_Field, 253 Node_Lit, 254 Type_Boolean, Type_Enum, 255 Type_Unsigned, Type_Signed, Type_Float, 256 Type_Array, Type_Subarray, Type_Subrecord, 257 Type_Access, Type_Record, Type_Union); 258 subtype Nodes_Subprogram is Node_Kind range Node_Function .. Node_Procedure; 259 260 type Node (<>); 261 type Node_Acc is access Node; 262 263 type Node_Array is array (Natural range <>) of Node_Acc; 264 265 type Node_Map (Len : Natural) is record 266 Map : Node_Array (1 .. Len); 267 end record; 268 type Node_Map_Acc is access Node_Map; 269 270 type Node_Array_Acc is access Node_Array; 271 272 type Node (Kind : Node_Kind) is record 273 case Kind is 274 when Decl_Keyword => 275 -- Keyword. 276 -- A keyword is not a declaration since the identifier has only 277 -- one meaning (the keyword). 278 Keyword : Token_Type; 279 when Decl_Type 280 | Decl_Param 281 | Node_Function 282 | Node_Procedure 283 | Node_Object 284 | Node_Lit => 285 -- Declarations 286 Decl_Storage : O_Storage; 287 -- For constants: True iff fully defined. 288 Decl_Defined : Boolean; 289 -- All declarations but NODE_PROCEDURE have a type. 290 Decl_Dtype : Node_Acc; 291 case Kind is 292 when Decl_Type => 293 -- Type declaration. 294 null; 295 when Decl_Param => 296 -- Parameter identifier. 297 Param_Name : Syment_Acc; 298 -- Parameter ortho node. 299 Param_Node : O_Dnode; 300 -- Next parameter of the parameters list. 301 Param_Next : Node_Acc; 302 when Node_Procedure 303 | Node_Function => 304 -- Subprogram symbol name. 305 Subprg_Name : Syment_Acc; 306 -- List of parameters. 307 Subprg_Params : Node_Acc; 308 -- Subprogram ortho node. 309 Subprg_Node : O_Dnode; 310 when Node_Object => 311 -- Name of the object (constant, variable). 312 Obj_Name : O_Ident; 313 -- Ortho node of the object. 314 Obj_Node : O_Dnode; 315 when Node_Lit => 316 -- Name of the literal. 317 Lit_Name : O_Ident; 318 -- Enum literal 319 Lit_Cnode : O_Cnode; 320 -- Next literal for the type. 321 Lit_Next : Node_Acc; 322 when others => 323 null; 324 end case; 325 when Node_Field => 326 -- Record field. 327 Field_Pos : Natural; -- From 1 to N. 328 Field_Ident : Syment_Acc; 329 Field_Fnode : O_Fnode; 330 Field_Type : Node_Acc; 331 Field_Next : Node_Acc; 332 -- Next entry in the field map (if the map exists). 333 Field_Hash_Next : Node_Acc; 334 when Type_Signed 335 | Type_Unsigned 336 | Type_Float 337 | Type_Array 338 | Type_Subarray 339 | Type_Record 340 | Type_Subrecord 341 | Type_Union 342 | Type_Access 343 | Type_Boolean 344 | Type_Enum => 345 -- Ortho node type. 346 Type_Onode : O_Tnode; 347 case Kind is 348 when Type_Array => 349 Array_Index : Node_Acc; 350 Array_Element : Node_Acc; 351 when Type_Subarray => 352 Subarray_Base : Node_Acc; 353 Subarray_El : Node_Acc; 354 when Type_Access => 355 Access_Dtype : Node_Acc; 356 when Type_Record 357 | Type_Union => 358 -- Simply linked list of fields. Works well unless the 359 -- number of fields is too high. 360 Record_Union_Fields : Node_Array_Acc; 361 -- Hash map of fields (the key is the hash of the ident). 362 Record_Union_Map : Node_Map_Acc; 363 when Type_Subrecord => 364 Subrecord_Base : Node_Acc; 365 Subrecord_Fields : Node_Array_Acc; 366 when Type_Enum 367 | Type_Boolean => 368 Enum_Lits : Node_Acc; 369 when Type_Float => 370 null; 371 when others => 372 null; 373 end case; 374 end case; 375 end record; 376 377 type Scope_Type; 378 type Scope_Acc is access Scope_Type; 379 380 type Name_Type is record 381 -- Current interpretation of the symbol. 382 Inter : Node_Acc; 383 -- Next declaration in the current scope. 384 Next : Syment_Acc; 385 -- Interpretation in a previous scope. 386 Up : Name_Acc; 387 -- Current scope. 388 Scope : Scope_Acc; 389 end record; 390 391 type Scope_Type is record 392 -- Simply linked list of names. 393 Names : Syment_Acc; 394 -- Previous scope. 395 Prev : Scope_Acc; 396 end record; 397 398 -- Return the current declaration for symbol SYM. 399 function Get_Decl (Sym : Syment_Acc) return Node_Acc; 400 pragma Inline (Get_Decl); 401 402 procedure Scan_Char (C : Character) 403 is 404 R : Character; 405 begin 406 407 if C = '\' then 408 R := Get_Char; 409 case R is 410 when 'n' => 411 R := LF; 412 when 'r' => 413 R := CR; 414 when ''' => 415 R := '''; 416 when '"' => -- " 417 R := '"'; -- " 418 when others => 419 Scan_Error ("bad character sequence \" & R); 420 end case; 421 else 422 R := C; 423 end if; 424 Token_Idlen := Token_Idlen + 1; 425 Token_Ident (Token_Idlen) := R; 426 end Scan_Char; 427 428 function Get_Hash (Str : String) return Hash_Type 429 is 430 Res : Hash_Type; 431 begin 432 Res := 0; 433 for I in Str'Range loop 434 Res := Res * 31 + Character'Pos (Str (I)); 435 end loop; 436 return Res; 437 end Get_Hash; 438 439 -- Previous token. 440 Tok_Previous : Token_Type; 441 442 function To_Digit (C : Character) return Integer is 443 begin 444 case C is 445 when '0' .. '9' => 446 return Character'Pos (C) - Character'Pos ('0'); 447 when 'A' .. 'F' => 448 return Character'Pos (C) - Character'Pos ('A') + 10; 449 when 'a' .. 'f' => 450 return Character'Pos (C) - Character'Pos ('a') + 10; 451 when others => 452 return -1; 453 end case; 454 end To_Digit; 455 456 function Is_Digit (C : Character) return Boolean is 457 begin 458 case C is 459 when '0' .. '9' 460 | 'A' .. 'F' 461 | 'a' .. 'f' => 462 return True; 463 when others => 464 return False; 465 end case; 466 end Is_Digit; 467 468 function Scan_Hex_Number return Token_Type 469 is 470 C : Character; 471 Exp : Integer; 472 Exp_Neg : Boolean; 473 After_Point : Natural; 474 begin 475 Token_Number := 0; 476 C := Get_Char; 477 if not Is_Digit (C) then 478 Scan_Error ("digit expected after '0x'"); 479 end if; 480 loop 481 Token_Number := Token_Number * 16 + Unsigned_64 (To_Digit (C)); 482 C := Get_Char; 483 exit when not Is_Digit (C); 484 end loop; 485 486 After_Point := 0; 487 if C = '.' then 488 loop 489 C := Get_Char; 490 exit when not Is_Digit (C); 491 if Shift_Right (Token_Number, 60) = 0 then 492 Token_Number := Token_Number * 16 + Unsigned_64 (To_Digit (C)); 493 After_Point := After_Point + 4; 494 end if; 495 end loop; 496 497 Exp := 0; 498 if C = 'p' or C = 'P' then 499 -- A real number. 500 C := Get_Char; 501 Exp_Neg := False; 502 if C = '-' then 503 Exp_Neg := True; 504 C := Get_Char; 505 elsif C = '+' then 506 C := Get_Char; 507 end if; 508 if not Is_Digit (C) then 509 Scan_Error ("digit expected after 'p'"); 510 end if; 511 loop 512 Exp := Exp * 10 + To_Digit (C); 513 C := Get_Char; 514 exit when not Is_Digit (C); 515 end loop; 516 if Exp_Neg then 517 Exp := -Exp; 518 end if; 519 end if; 520 Exp := Exp - After_Point; 521 Unget_Char; 522 Token_Float := 523 IEEE_Float_64'Scaling (IEEE_Float_64 (Token_Number), Exp); 524 return Tok_Float_Num; 525 else 526 Unget_Char; 527 return Tok_Num; 528 end if; 529 end Scan_Hex_Number; 530 531 function Scan_Fp_Number return Token_Type 532 is 533 After_Point : Integer; 534 C : Character; 535 Exp : Integer; 536 Exp_Neg : Boolean; 537 begin 538 -- A real number. 539 After_Point := 0; 540 Token_Float := IEEE_Float_64 (Token_Number); 541 loop 542 C := Get_Char; 543 exit when C not in '0' .. '9'; 544 Token_Float := Token_Float * 10.0 + IEEE_Float_64 (To_Digit (C)); 545 After_Point := After_Point + 1; 546 end loop; 547 if C = 'e' or C = 'E' then 548 Exp := 0; 549 C := Get_Char; 550 Exp_Neg := False; 551 if C = '-' then 552 Exp_Neg := True; 553 C := Get_Char; 554 elsif C = '+' then 555 C := Get_Char; 556 elsif not Is_Digit (C) then 557 Scan_Error ("digit expected"); 558 end if; 559 while Is_Digit (C) loop 560 Exp := Exp * 10 + To_Digit (C); 561 C := Get_Char; 562 end loop; 563 if Exp_Neg then 564 Exp := -Exp; 565 end if; 566 Exp := Exp - After_Point; 567 else 568 Exp := - After_Point; 569 end if; 570 Unget_Char; 571 Token_Float := Token_Float * 10.0 ** Exp; 572 if Token_Float > IEEE_Float_64'Last then 573 Token_Float := IEEE_Float_64'Last; 574 end if; 575 return Tok_Float_Num; 576 end Scan_Fp_Number; 577 578 function Scan_Number (First_Char : Character) return Token_Type 579 is 580 C : Character; 581 Base : Unsigned_64; 582 begin 583 C := First_Char; 584 Token_Number := 0; 585 586 -- Handle '0x' prefix. 587 if C = '0' then 588 -- '0' can be discarded. 589 C := Get_Char; 590 if C = 'x' or C = 'X' then 591 return Scan_Hex_Number; 592 elsif C = '.' then 593 return Scan_Fp_Number; 594 elsif not Is_Digit (C) then 595 Unget_Char; 596 return Tok_Num; 597 end if; 598 end if; 599 600 loop 601 Token_Number := Token_Number * 10 + Unsigned_64 (To_Digit (C)); 602 C := Get_Char; 603 exit when not Is_Digit (C); 604 end loop; 605 if C = '#' then 606 Base := Token_Number; 607 Token_Number := 0; 608 C := Get_Char; 609 loop 610 if C /= '_' then 611 Token_Number := 612 Token_Number * Base + Unsigned_64 (To_Digit (C)); 613 end if; 614 C := Get_Char; 615 exit when C = '#'; 616 end loop; 617 return Tok_Num; 618 end if; 619 if C = '.' then 620 return Scan_Fp_Number; 621 else 622 Unget_Char; 623 return Tok_Num; 624 end if; 625 end Scan_Number; 626 627 procedure Scan_Comment 628 is 629 C : Character; 630 begin 631 Token_Idlen := 0; 632 loop 633 C := Get_Char; 634 exit when C = CR or C = LF; 635 Token_Idlen := Token_Idlen + 1; 636 Token_Ident (Token_Idlen) := C; 637 end loop; 638 Unget_Char; 639 end Scan_Comment; 640 641 function Get_Ident_Token return Token_Type 642 is 643 H : Hash_Type; 644 S : Syment_Acc; 645 N : Node_Acc; 646 begin 647 H := Token_Hash mod Symtable.Max; 648 S := Symtable.Map (H); 649 while S /= null loop 650 if S.Hash = Token_Hash 651 and then Is_Equal (S.Ident, Token_Ident (1 .. Token_Idlen)) 652 then 653 -- This identifier is known. 654 Token_Sym := S; 655 656 -- It may be a keyword. 657 if S.Name /= null then 658 N := Get_Decl (S); 659 if N.Kind = Decl_Keyword then 660 return N.Keyword; 661 end if; 662 end if; 663 664 return Tok_Ident; 665 end if; 666 S := S.Next; 667 end loop; 668 669 Nbr_Syment := Nbr_Syment + 1; 670 if Nbr_Syment >= Max_Syment 671 and then Cur_Prime_Idx < Hash_Primes'Last 672 then 673 -- Resize. 674 Cur_Prime_Idx := Cur_Prime_Idx + 1; 675 Max_Syment := Max_Syment * 2; 676 677 declare 678 procedure Free is new Ada.Unchecked_Deallocation 679 (Syment_Acc_Map, Syment_Acc_Map_Acc); 680 New_Table : Syment_Acc_Map_Acc; 681 Ns, Next_Ns : Syment_Acc; 682 Nh : Hash_Type; 683 begin 684 New_Table := new Syment_Acc_Map (Hash_Primes (Cur_Prime_Idx)); 685 686 -- Fill the new hash table. 687 for I in Symtable.Map'Range loop 688 Ns := Symtable.Map (I); 689 while Ns /= null loop 690 Next_Ns := Ns.Next; 691 692 Nh := Ns.Hash mod New_Table.Max; 693 Ns.Next := New_Table.Map (Nh); 694 New_Table.Map (Nh) := Ns; 695 696 Ns := Next_Ns; 697 end loop; 698 end loop; 699 700 -- Replace the old one with the new one. 701 Free (Symtable); 702 Symtable := New_Table; 703 end; 704 705 -- Recompute H 706 H := Token_Hash mod Symtable.Max; 707 end if; 708 709 Symtable.Map (H) := new Syment_Type' 710 (Hash => Token_Hash, 711 Ident => Get_Identifier (Token_Ident (1 .. Token_Idlen)), 712 Next => Symtable.Map (H), 713 Name => null); 714 Token_Sym := Symtable.Map (H); 715 return Tok_Ident; 716 end Get_Ident_Token; 717 718 -- Get the next token. 719 function Get_Token return Token_Type 720 is 721 C : Character; 722 begin 723 loop 724 725 C := Get_Char; 726 << Again >> null; 727 case C is 728 when NUL => 729 return Tok_Eof; 730 when ' ' | HT => 731 null; 732 when LF => 733 Lineno := Lineno + 1; 734 C := Get_Char; 735 if C /= CR then 736 goto Again; 737 end if; 738 when CR => 739 Lineno := Lineno + 1; 740 C := Get_Char; 741 if C /= LF then 742 goto Again; 743 end if; 744 when '+' => 745 return Tok_Plus; 746 when '-' => 747 C := Get_Char; 748 if C = '-' then 749 C := Get_Char; 750 if C = '#' then 751 return Tok_Line_Number; 752 elsif C = 'F' then 753 Scan_Comment; 754 return Tok_File_Name; 755 elsif C = ' ' then 756 Scan_Comment; 757 return Tok_Comment; 758 else 759 Scan_Error ("bad comment"); 760 end if; 761 else 762 Unget_Char; 763 return Tok_Minus; 764 end if; 765 when '/' => 766 C := Get_Char; 767 if C = '=' then 768 return Tok_Not_Equal; 769 else 770 Unget_Char; 771 return Tok_Div; 772 end if; 773 when '*' => 774 return Tok_Star; 775 when '#' => 776 return Tok_Sharp; 777 when '=' => 778 C := Get_Char; 779 if C = '>' then 780 return Tok_Arrow; 781 else 782 Unget_Char; 783 return Tok_Equal; 784 end if; 785 when '>' => 786 C := Get_Char; 787 if C = '=' then 788 return Tok_Greater_Eq; 789 else 790 Unget_Char; 791 return Tok_Greater; 792 end if; 793 when '(' => 794 return Tok_Left_Paren; 795 when ')' => 796 return Tok_Right_Paren; 797 when '{' => 798 return Tok_Left_Brace; 799 when '}' => 800 return Tok_Right_Brace; 801 when '[' => 802 return Tok_Left_Brack; 803 when ']' => 804 return Tok_Right_Brack; 805 when '<' => 806 C := Get_Char; 807 if C = '=' then 808 return Tok_Less_Eq; 809 else 810 Unget_Char; 811 return Tok_Less; 812 end if; 813 when ':' => 814 C := Get_Char; 815 if C = '=' then 816 return Tok_Assign; 817 else 818 Unget_Char; 819 return Tok_Colon; 820 end if; 821 when '.' => 822 C := Get_Char; 823 if C = '.' then 824 C := Get_Char; 825 if C = '.' then 826 return Tok_Elipsis; 827 else 828 Scan_Error ("'...' expected"); 829 end if; 830 else 831 Unget_Char; 832 return Tok_Dot; 833 end if; 834 when ';' => 835 return Tok_Semicolon; 836 when ',' => 837 return Tok_Comma; 838 when '@' => 839 return Tok_Arob; 840 when ''' => 841 if Tok_Previous = Tok_Ident then 842 return Tok_Tick; 843 else 844 Token_Number := Character'Pos (Get_Char); 845 C := Get_Char; 846 if C /= ''' then 847 Scan_Error ("ending single quote expected"); 848 end if; 849 return Tok_Num; 850 end if; 851 when '"' => -- " 852 -- Eat double quote. 853 C := Get_Char; 854 Token_Idlen := 0; 855 loop 856 Scan_Char (C); 857 C := Get_Char; 858 exit when C = '"'; -- " 859 end loop; 860 return Tok_String; 861 when '0' .. '9' => 862 return Scan_Number (C); 863 when 'a' .. 'z' 864 | 'A' .. 'Z' 865 | '_' => 866 Token_Idlen := 0; 867 Token_Hash := 0; 868 loop 869 Token_Idlen := Token_Idlen + 1; 870 Token_Ident (Token_Idlen) := C; 871 Token_Hash := Token_Hash * 31 + Character'Pos (C); 872 C := Get_Char; 873 exit when (C < 'A' or C > 'Z') 874 and (C < 'a' or C > 'z') 875 and (C < '0' or C > '9') 876 and (C /= '_'); 877 end loop; 878 Unget_Char; 879 return Get_Ident_Token; 880 when others => 881 Scan_Error ("Bad character:" 882 & Integer'Image (Character'Pos (C)) 883 & C); 884 return Tok_Eof; 885 end case; 886 end loop; 887 end Get_Token; 888 889 -- The current token. 890 Tok : Token_Type; 891 892 procedure Next_Token is 893 begin 894 Tok_Previous := Tok; 895 Tok := Get_Token; 896 end Next_Token; 897 898 procedure Expect (T : Token_Type; Msg : String := "") is 899 begin 900 if Tok /= T then 901 if Msg'Length = 0 then 902 case T is 903 when Tok_Left_Brace => 904 Parse_Error ("'{' expected"); 905 when others => 906 if Tok = Tok_Ident then 907 Parse_Error 908 (Token_Type'Image (T) & " expected, found '" & 909 Token_Ident (1 .. Token_Idlen) & "'"); 910 else 911 Parse_Error (Token_Type'Image (T) & " expected, found " 912 & Token_Type'Image (Tok)); 913 end if; 914 end case; 915 else 916 Parse_Error (Msg); 917 end if; 918 end if; 919 end Expect; 920 921 procedure Next_Expect (T : Token_Type; Msg : String := "") is 922 begin 923 Next_Token; 924 Expect (T, Msg); 925 end Next_Expect; 926 927 -- Scopes and identifiers. 928 929 930 -- Current scope. 931 Scope : Scope_Acc := null; 932 933 -- Add a declaration for symbol SYM in the current scope. 934 -- INTER defines the meaning of the declaration. 935 -- There must be at most one declaration for a symbol in the current scope, 936 -- i.e. a symbol cannot be redefined. 937 procedure Add_Decl (Sym : Syment_Acc; Inter : Node_Acc); 938 939 -- Return TRUE iff SYM is already defined in the current scope. 940 function Is_Defined (Sym : Syment_Acc) return Boolean; 941 942 -- Create new scope. 943 procedure Push_Scope; 944 945 -- Close the current scope. Symbols defined in the scope regain their 946 -- previous declaration. 947 procedure Pop_Scope; 948 949 950 procedure Push_Scope 951 is 952 Nscope : Scope_Acc; 953 begin 954 Nscope := new Scope_Type'(Names => null, Prev => Scope); 955 Scope := Nscope; 956 end Push_Scope; 957 958 procedure Pop_Scope 959 is 960 procedure Free is new Ada.Unchecked_Deallocation 961 (Object => Name_Type, Name => Name_Acc); 962 963 procedure Free is new Ada.Unchecked_Deallocation 964 (Object => Scope_Type, Name => Scope_Acc); 965 966 Sym : Syment_Acc; 967 N_Sym : Syment_Acc; 968 Name : Name_Acc; 969 Old_Scope : Scope_Acc; 970 begin 971 Sym := Scope.Names; 972 while Sym /= null loop 973 Name := Sym.Name; 974 -- Check. 975 if Name.Scope /= Scope then 976 raise Program_Error; 977 end if; 978 979 -- Set the interpretation of this symbol. 980 Sym.Name := Name.Up; 981 982 N_Sym := Name.Next; 983 984 Free (Name); 985 Sym := N_Sym; 986 end loop; 987 988 -- Free scope. 989 Old_Scope := Scope; 990 Scope := Scope.Prev; 991 Free (Old_Scope); 992 end Pop_Scope; 993 994 function Is_Defined (Sym : Syment_Acc) return Boolean is 995 begin 996 if Sym.Name /= null 997 and then Sym.Name.Scope = Scope 998 then 999 return True; 1000 else 1001 return False; 1002 end if; 1003 end Is_Defined; 1004 1005 function New_Symbol (Str : String) return Syment_Acc 1006 is 1007 Ent : Syment_Acc; 1008 H : Hash_Type; 1009 begin 1010 Ent := new Syment_Type'(Hash => Get_Hash (Str), 1011 Ident => Get_Identifier (Str), 1012 Next => null, 1013 Name => null); 1014 H := Ent.Hash mod Symtable.Max; 1015 Ent.Next := Symtable.Map (H); 1016 Symtable.Map (H) := Ent; 1017 1018 Nbr_Syment := Nbr_Syment + 1; 1019 1020 -- This function doesn't handle resizing, as it is called only for 1021 -- keywords during initialization. Be sure to use a big enough initial 1022 -- size for the hash table. 1023 pragma Assert (Nbr_Syment < Max_Syment); 1024 1025 return Ent; 1026 end New_Symbol; 1027 1028 procedure Add_Keyword (Str : String; Token : Token_Type) 1029 is 1030 Kw : String (Str'Range); 1031 Ent : Syment_Acc; 1032 begin 1033 -- Convert to uppercase. 1034 for I in Str'Range loop 1035 pragma Assert (Str (I) in 'a' .. 'z'); 1036 Kw (I) := Character'Val 1037 (Character'Pos ('A') 1038 + Character'Pos (Str (I)) - Character'Pos ('a')); 1039 end loop; 1040 1041 Ent := New_Symbol (Kw); 1042 if Ent.Name /= null 1043 or else Scope /= null 1044 then 1045 -- Redefinition of a keyword. 1046 raise Program_Error; 1047 end if; 1048 Ent.Name := new Name_Type'(Inter => new Node'(Kind => Decl_Keyword, 1049 Keyword => Token), 1050 Next => null, 1051 Up => null, 1052 Scope => null); 1053 end Add_Keyword; 1054 1055 procedure Add_Decl (Sym : Syment_Acc; Inter : Node_Acc) 1056 is 1057 Name : Name_Acc; 1058 Prev : Node_Acc; 1059 begin 1060 Name := Sym.Name; 1061 if Name /= null and then Name.Scope = Scope then 1062 Prev := Name.Inter; 1063 if Prev.Kind = Inter.Kind 1064 and then Prev.Kind /= Node_Field 1065 and then Prev.Decl_Dtype = Inter.Decl_Dtype 1066 and then Prev.Decl_Storage = O_Storage_External 1067 and then Inter.Decl_Storage = O_Storage_Public 1068 then 1069 -- Redefinition 1070 Name.Inter := Inter; 1071 return; 1072 end if; 1073 Parse_Error ("redefinition of " & Get_String (Sym.Ident)); 1074 end if; 1075 Name := new Name_Type'(Inter => Inter, 1076 Next => Scope.Names, 1077 Up => Sym.Name, 1078 Scope => Scope); 1079 Sym.Name := Name; 1080 Scope.Names := Sym; 1081 end Add_Decl; 1082 1083 function Get_Decl (Sym : Syment_Acc) return Node_Acc is 1084 begin 1085 if Sym.Name = null then 1086 Parse_Error ("undefined identifier " & Get_String (Sym.Ident)); 1087 else 1088 return Sym.Name.Inter; 1089 end if; 1090 end Get_Decl; 1091 1092 function Parse_Constant_Value (Atype : Node_Acc) return O_Cnode; 1093 function Parse_Address (Prefix : Node_Acc) return O_Enode; 1094 function Parse_Constant_Address (Prefix : Node_Acc) return O_Cnode; 1095 procedure Parse_Declaration; 1096 procedure Parse_Compound_Statement; 1097 1098 function Parse_Type return Node_Acc; 1099 1100 -- Return the index of FIELD in map MAP. 1101 function Field_Map_Index (Map : Node_Map_Acc; Sym : Syment_Acc) 1102 return Natural is 1103 begin 1104 return 1 + Natural (Sym.Hash mod Hash_Type (Map.Len)); 1105 end Field_Map_Index; 1106 1107 -- Grammar: 1108 -- { ident : type ; } 1109 -- end 1110 function Parse_Fields return Node_Array_Acc 1111 is 1112 F_Type : Node_Acc; 1113 F : Syment_Acc; 1114 First_Field : Node_Acc; 1115 Last_Field : Node_Acc; 1116 Field : Node_Acc; 1117 Num : Natural; 1118 Res : Node_Array_Acc; 1119 begin 1120 Push_Scope; 1121 1122 Last_Field := null; 1123 First_Field := null; 1124 Num := 0; 1125 loop 1126 exit when Tok = Tok_End; 1127 exit when Tok = Tok_Right_Paren; 1128 1129 if Tok /= Tok_Ident then 1130 Parse_Error ("field name expected"); 1131 end if; 1132 1133 Num := Num + 1; 1134 1135 F := Token_Sym; 1136 Next_Expect (Tok_Colon, "':' expected"); 1137 Next_Token; 1138 F_Type := Parse_Type; 1139 Field := new Node'(Kind => Node_Field, 1140 Field_Pos => Num, 1141 Field_Ident => F, 1142 Field_Fnode => O_Fnode_Null, 1143 Field_Type => F_Type, 1144 Field_Next => null, 1145 Field_Hash_Next => null); 1146 1147 -- Check fields are uniq. 1148 Add_Decl (F, Field); 1149 1150 -- Append field 1151 if Last_Field = null then 1152 First_Field := Field; 1153 else 1154 Last_Field.Field_Next := Field; 1155 end if; 1156 Last_Field := Field; 1157 1158 Expect (Tok_Semicolon, "';' expected"); 1159 Next_Token; 1160 end loop; 1161 1162 Pop_Scope; 1163 1164 Res := new Node_Array(1 .. Num); 1165 for I in Res'Range loop 1166 Res (I) := First_Field; 1167 First_Field := First_Field.Field_Next; 1168 end loop; 1169 1170 return Res; 1171 end Parse_Fields; 1172 1173 procedure Parse_Fields (Aggr_Type : Node_Acc; 1174 Constr : in out O_Element_List) 1175 is 1176 Fields : Node_Array_Acc; 1177 Field : Node_Acc; 1178 begin 1179 Fields := Parse_Fields; 1180 Expect (Tok_End, "end expected"); 1181 Aggr_Type.Record_Union_Fields := Fields; 1182 1183 for I in Fields'Range loop 1184 Field := Fields (I); 1185 case Aggr_Type.Kind is 1186 when Type_Record => 1187 New_Record_Field (Constr, Field.Field_Fnode, 1188 Field.Field_Ident.Ident, 1189 Field.Field_Type.Type_Onode); 1190 when Type_Union => 1191 New_Union_Field (Constr, Field.Field_Fnode, 1192 Field.Field_Ident.Ident, 1193 Field.Field_Type.Type_Onode); 1194 when others => 1195 raise Program_Error; 1196 end case; 1197 end loop; 1198 1199 -- Create a map if there are a lot of fields. 1200 if Fields'Last > 16 then 1201 declare 1202 Map : Node_Map_Acc; 1203 Idx : Natural; 1204 begin 1205 Map := new Node_Map'(Len => Fields'Last / 3, 1206 Map => (others => null)); 1207 Aggr_Type.Record_Union_Map := Map; 1208 for I in Fields'Range loop 1209 Field := Fields (I); 1210 Idx := Field_Map_Index (Map, Field.Field_Ident); 1211 Field.Field_Hash_Next := Map.Map (Idx); 1212 Map.Map (Idx) := Field; 1213 end loop; 1214 end; 1215 end if; 1216 end Parse_Fields; 1217 1218 procedure Parse_Record_Type (Def : Node_Acc) 1219 is 1220 Constr : O_Element_List; 1221 begin 1222 if Def.Type_Onode = O_Tnode_Null then 1223 Start_Record_Type (Constr); 1224 else 1225 Start_Uncomplete_Record_Type (Def.Type_Onode, Constr); 1226 end if; 1227 Parse_Fields (Def, Constr); 1228 Next_Expect (Tok_Record, "end record expected"); 1229 Finish_Record_Type (Constr, Def.Type_Onode); 1230 end Parse_Record_Type; 1231 1232 procedure Parse_Subrecord_Type (Def : Node_Acc) 1233 is 1234 Base : Node_Acc; 1235 Constr : O_Element_Sublist; 1236 Fields : Node_Array_Acc; 1237 Field : Node_Acc; 1238 begin 1239 Base := Parse_Type; 1240 if Base.Kind /= Type_Record then 1241 Parse_Error ("subrecord base type must be a record type"); 1242 end if; 1243 Def.Subrecord_Base := Base; 1244 Expect (Tok_Left_Paren); 1245 Next_Token; 1246 1247 Fields := Parse_Fields; 1248 Def.Subrecord_Fields := Fields; 1249 Expect (Tok_Right_Paren); 1250 1251 Start_Record_Subtype (Base.Type_Onode, Constr); 1252 for I in Fields'Range loop 1253 Field := Fields (I); 1254 New_Subrecord_Field (Constr, Field.Field_Fnode, 1255 Field.Field_Type.Type_Onode); 1256 end loop; 1257 Finish_Record_Subtype (Constr, Def.Type_Onode); 1258 end Parse_Subrecord_Type; 1259 1260 procedure Parse_Union_Type (Def : Node_Acc) 1261 is 1262 Constr : O_Element_List; 1263 begin 1264 Start_Union_Type (Constr); 1265 Parse_Fields (Def, Constr); 1266 Next_Expect (Tok_Union, "end union expected"); 1267 Finish_Union_Type (Constr, Def.Type_Onode); 1268 end Parse_Union_Type; 1269 1270 function Parse_Type return Node_Acc 1271 is 1272 Res : Node_Acc; 1273 T : Token_Type; 1274 begin 1275 T := Tok; 1276 case T is 1277 when Tok_Unsigned 1278 | Tok_Signed => 1279 Next_Expect (Tok_Left_Paren, "'(' expected"); 1280 Next_Expect (Tok_Num, "number expected"); 1281 case T is 1282 when Tok_Unsigned => 1283 Res := new Node' 1284 (Kind => Type_Unsigned, 1285 Type_Onode => New_Unsigned_Type (Natural 1286 (Token_Number))); 1287 when Tok_Signed => 1288 Res := new Node' 1289 (Kind => Type_Signed, 1290 Type_Onode => New_Signed_Type (Natural 1291 (Token_Number))); 1292 when others => 1293 raise Program_Error; 1294 end case; 1295 Next_Expect (Tok_Right_Paren, "')' expected"); 1296 when Tok_Float => 1297 Res := new Node'(Kind => Type_Float, 1298 Type_Onode => New_Float_Type); 1299 when Tok_Array => 1300 declare 1301 Index_Node : Node_Acc; 1302 El_Node : Node_Acc; 1303 begin 1304 Next_Expect (Tok_Left_Brack, "'[' expected"); 1305 Next_Token; 1306 Index_Node := Parse_Type; 1307 Expect (Tok_Right_Brack, "']' expected"); 1308 Next_Expect (Tok_Of, "'OF' expected"); 1309 Next_Token; 1310 El_Node := Parse_Type; 1311 Res := new Node' 1312 (Kind => Type_Array, 1313 Type_Onode => New_Array_Type (El_Node.Type_Onode, 1314 Index_Node.Type_Onode), 1315 Array_Index => Index_Node, 1316 Array_Element => El_Node); 1317 end; 1318 return Res; 1319 when Tok_Subarray => 1320 -- Grammar: 1321 -- SUBARRAY type '[' len ']' [ OF eltype ] 1322 declare 1323 Base_Node : Node_Acc; 1324 Len : O_Cnode; 1325 El_Node : Node_Acc; 1326 Res_Type : O_Tnode; 1327 begin 1328 Next_Token; 1329 Base_Node := Parse_Type; 1330 if Base_Node.Kind /= Type_Array then 1331 Parse_Error ("subarray base type is not an array type"); 1332 end if; 1333 Expect (Tok_Left_Brack); 1334 Next_Token; 1335 Len := Parse_Constant_Value (Base_Node.Array_Index); 1336 Expect (Tok_Right_Brack); 1337 Next_Token; 1338 if Tok = Tok_Of then 1339 Next_Token; 1340 El_Node := Parse_Type; 1341 -- TODO: check this is a subtype of the element 1342 else 1343 El_Node := Base_Node.Array_Element; 1344 -- TODO: check EL_NODE is constrained. 1345 end if; 1346 Res_Type := New_Array_Subtype 1347 (Base_Node.Type_Onode, El_Node.Type_Onode, Len); 1348 Res := new Node' (Kind => Type_Subarray, 1349 Type_Onode => Res_Type, 1350 Subarray_Base => Base_Node, 1351 Subarray_El => El_Node); 1352 return Res; 1353 end; 1354 when Tok_Ident => 1355 declare 1356 Inter : Node_Acc; 1357 begin 1358 Inter := Get_Decl (Token_Sym); 1359 if Inter = null then 1360 Parse_Error ("undefined type name symbol " 1361 & Get_String (Token_Sym.Ident)); 1362 end if; 1363 if Inter.Kind /= Decl_Type then 1364 Parse_Error ("type declarator expected"); 1365 end if; 1366 Res := Inter.Decl_Dtype; 1367 end; 1368 when Tok_Access => 1369 declare 1370 Dtype : Node_Acc; 1371 begin 1372 Next_Token; 1373 if Tok = Tok_Semicolon then 1374 Res := new Node' 1375 (Kind => Type_Access, 1376 Type_Onode => New_Access_Type (O_Tnode_Null), 1377 Access_Dtype => null); 1378 else 1379 Dtype := Parse_Type; 1380 Res := new Node' 1381 (Kind => Type_Access, 1382 Type_Onode => New_Access_Type (Dtype.Type_Onode), 1383 Access_Dtype => Dtype); 1384 end if; 1385 return Res; 1386 end; 1387 when Tok_Record => 1388 Next_Token; 1389 if Tok = Tok_Semicolon then 1390 -- Uncomplete record type. 1391 Res := new Node'(Kind => Type_Record, 1392 Type_Onode => O_Tnode_Null, 1393 Record_Union_Fields => null, 1394 Record_Union_Map => null); 1395 New_Uncomplete_Record_Type (Res.Type_Onode); 1396 return Res; 1397 end if; 1398 1399 Res := new Node'(Kind => Type_Record, 1400 Type_Onode => O_Tnode_Null, 1401 Record_Union_Fields => null, 1402 Record_Union_Map => null); 1403 Parse_Record_Type (Res); 1404 when Tok_Subrecord => 1405 Next_Token; 1406 Res := new Node'(Kind => Type_Subrecord, 1407 Type_Onode => O_Tnode_Null, 1408 Subrecord_Base => null, 1409 Subrecord_Fields => null); 1410 Parse_Subrecord_Type (Res); 1411 when Tok_Union => 1412 Next_Token; 1413 Res := new Node'(Kind => Type_Union, 1414 Type_Onode => O_Tnode_Null, 1415 Record_Union_Fields => null, 1416 Record_Union_Map => null); 1417 Parse_Union_Type (Res); 1418 1419 when Tok_Boolean => 1420 declare 1421 False_Lit, True_Lit : Node_Acc; 1422 begin 1423 Res := new Node'(Kind => Type_Boolean, 1424 Type_Onode => O_Tnode_Null, 1425 Enum_Lits => null); 1426 Next_Expect (Tok_Left_Brace, "'{' expected"); 1427 Next_Expect (Tok_Ident, "identifier expected"); 1428 False_Lit := new Node'(Kind => Node_Lit, 1429 Decl_Dtype => Res, 1430 Decl_Storage => O_Storage_Public, 1431 Decl_Defined => False, 1432 Lit_Name => Token_Sym.Ident, 1433 Lit_Cnode => O_Cnode_Null, 1434 Lit_Next => null); 1435 Next_Expect (Tok_Comma, "',' expected"); 1436 Next_Expect (Tok_Ident, "identifier expected"); 1437 True_Lit := new Node'(Kind => Node_Lit, 1438 Decl_Dtype => Res, 1439 Decl_Storage => O_Storage_Public, 1440 Decl_Defined => False, 1441 Lit_Name => Token_Sym.Ident, 1442 Lit_Cnode => O_Cnode_Null, 1443 Lit_Next => null); 1444 Next_Expect (Tok_Right_Brace, "'}' expected"); 1445 False_Lit.Lit_Next := True_Lit; 1446 Res.Enum_Lits := False_Lit; 1447 New_Boolean_Type (Res.Type_Onode, 1448 False_Lit.Lit_Name, False_Lit.Lit_Cnode, 1449 True_Lit.Lit_Name, True_Lit.Lit_Cnode); 1450 end; 1451 when Tok_Enum => 1452 -- Grammar: 1453 -- ENUM { LIT1, LIT2, ... LITN } 1454 declare 1455 List : O_Enum_List; 1456 Lit : Node_Acc; 1457 Last_Lit : Node_Acc; 1458 begin 1459 Res := new Node'(Kind => Type_Enum, 1460 Type_Onode => O_Tnode_Null, 1461 Enum_Lits => null); 1462 Last_Lit := null; 1463 Push_Scope; 1464 Next_Expect (Tok_Left_Brace); 1465 Next_Token; 1466 -- FIXME: set a size to the enum. 1467 Start_Enum_Type (List, 8); 1468 loop 1469 Expect (Tok_Ident); 1470 Lit := new Node'(Kind => Node_Lit, 1471 Decl_Dtype => Res, 1472 Decl_Storage => O_Storage_Public, 1473 Decl_Defined => False, 1474 Lit_Name => Token_Sym.Ident, 1475 Lit_Cnode => O_Cnode_Null, 1476 Lit_Next => null); 1477 Add_Decl (Token_Sym, Lit); 1478 New_Enum_Literal (List, Lit.Lit_Name, Lit.Lit_Cnode); 1479 if Last_Lit = null then 1480 Res.Enum_Lits := Lit; 1481 else 1482 Last_Lit.Lit_Next := Lit; 1483 end if; 1484 Last_Lit := Lit; 1485 1486 Next_Token; 1487 if Tok = Tok_Equal then 1488 -- By compatibility, support '= N' after a literal. 1489 Next_Expect (Tok_Num); 1490 Next_Token; 1491 end if; 1492 exit when Tok = Tok_Right_Brace; 1493 Expect (Tok_Comma); 1494 Next_Token; 1495 end loop; 1496 Finish_Enum_Type (List, Res.Type_Onode); 1497 Pop_Scope; 1498 end; 1499 when others => 1500 Parse_Error ("bad type " & Token_Type'Image (Tok)); 1501 return null; 1502 end case; 1503 Next_Token; 1504 return Res; 1505 end Parse_Type; 1506 1507 procedure Parse_Type_Completion (Decl : Node_Acc) 1508 is 1509 begin 1510 case Tok is 1511 when Tok_Record => 1512 Next_Token; 1513 Parse_Record_Type (Decl.Decl_Dtype); 1514 Next_Token; 1515 when Tok_Access => 1516 Next_Token; 1517 declare 1518 Dtype : Node_Acc; 1519 begin 1520 Dtype := Parse_Type; 1521 Decl.Decl_Dtype.Access_Dtype := Dtype; 1522 Finish_Access_Type (Decl.Decl_Dtype.Type_Onode, 1523 Dtype.Type_Onode); 1524 end; 1525 when others => 1526 Parse_Error ("'access' or 'record' expected"); 1527 end case; 1528 end Parse_Type_Completion; 1529 1530-- procedure Parse_Declaration; 1531 1532 procedure Parse_Expression (Expr_Type : Node_Acc; 1533 Expr : out O_Enode; 1534 Res_Type : out Node_Acc); 1535 procedure Parse_Name (Prefix : Node_Acc; 1536 Name : out O_Lnode; N_Type : out Node_Acc); 1537 procedure Parse_Lvalue (N : in out O_Lnode; N_Type : in out Node_Acc); 1538 1539 -- Expect: '(' 1540 -- Let: next token. 1541 procedure Parse_Association (Constr : in out O_Assoc_List; 1542 Decl : Node_Acc); 1543 1544 function Find_Field_By_Name (Aggr_Type : Node_Acc) return Node_Acc 1545 is 1546 Map : Node_Map_Acc; 1547 Field : Node_Acc; 1548 Fields : Node_Array_Acc; 1549 begin 1550 case Aggr_Type.Kind is 1551 when Type_Record 1552 | Type_Union => 1553 Map := Aggr_Type.Record_Union_Map; 1554 Fields := Aggr_Type.Record_Union_Fields; 1555 when Type_Subrecord => 1556 Map := Aggr_Type.Subrecord_Base.Record_Union_Map; 1557 Fields := Aggr_Type.Subrecord_Fields; 1558 when others => 1559 raise Program_Error; 1560 end case; 1561 1562 if Map /= null then 1563 -- Look in the hash map if it is present. 1564 Field := Map.Map (Field_Map_Index (Map, Token_Sym)); 1565 while Field /= null loop 1566 if Field.Field_Ident = Token_Sym then 1567 -- Get the field by position as the map is shared between 1568 -- a record and its subrecords. 1569 Field := Fields (Field.Field_Pos); 1570 exit; 1571 end if; 1572 Field := Field.Field_Hash_Next; 1573 end loop; 1574 else 1575 -- Linear look. 1576 Field := null; 1577 for I in Fields'Range loop 1578 if Fields (I).Field_Ident = Token_Sym then 1579 Field := Fields (I); 1580 exit; 1581 end if; 1582 end loop; 1583 end if; 1584 1585 if Field = null then 1586 Parse_Error ("no such field name"); 1587 end if; 1588 return Field; 1589 end Find_Field_By_Name; 1590 1591 -- expect: offsetof id. 1592 function Parse_Offsetof (Atype : Node_Acc) return O_Cnode 1593 is 1594 Rec_Type : Node_Acc; 1595 Rec_Field : Node_Acc; 1596 begin 1597 Next_Expect (Tok_Left_Paren); 1598 Next_Expect (Tok_Ident); 1599 Rec_Type := Get_Decl (Token_Sym); 1600 if Rec_Type.Kind /= Decl_Type 1601 or else (Rec_Type.Decl_Dtype.Kind /= Type_Record 1602 and then Rec_Type.Decl_Dtype.Kind /= Type_Subrecord) 1603 then 1604 Parse_Error ("record type name expected"); 1605 end if; 1606 Next_Expect (Tok_Dot); 1607 Next_Expect (Tok_Ident); 1608 Rec_Field := Find_Field_By_Name (Rec_Type.Decl_Dtype); 1609 Next_Expect (Tok_Right_Paren); 1610 return New_Offsetof (Rec_Type.Decl_Dtype.Type_Onode, 1611 Rec_Field.Field_Fnode, 1612 Atype.Type_Onode); 1613 end Parse_Offsetof; 1614 1615 function Parse_Type_Attribute return Node_Acc 1616 is 1617 Res : Node_Acc; 1618 begin 1619 Next_Expect (Tok_Left_Paren); 1620 Next_Token; 1621 if Tok /= Tok_Ident then 1622 Parse_Error ("type name expected"); 1623 end if; 1624 Res := Get_Decl (Token_Sym).Decl_Dtype; 1625 Next_Expect (Tok_Right_Paren); 1626 return Res; 1627 end Parse_Type_Attribute; 1628 1629 function Parse_Sizeof (Atype : Node_Acc) return O_Cnode 1630 is 1631 T : Node_Acc; 1632 begin 1633 T := Parse_Type_Attribute; 1634 return New_Sizeof (T.Type_Onode, Atype.Type_Onode); 1635 end Parse_Sizeof; 1636 1637 function Parse_Record_Sizeof (Atype : Node_Acc) return O_Cnode 1638 is 1639 T : Node_Acc; 1640 begin 1641 T := Parse_Type_Attribute; 1642 return New_Record_Sizeof (T.Type_Onode, Atype.Type_Onode); 1643 end Parse_Record_Sizeof; 1644 1645 function Parse_Alignof (Atype : Node_Acc) return O_Cnode 1646 is 1647 T : Node_Acc; 1648 begin 1649 T := Parse_Type_Attribute; 1650 return New_Alignof (T.Type_Onode, Atype.Type_Onode); 1651 end Parse_Alignof; 1652 1653 function Parse_Minus_Num (Atype : Node_Acc) return O_Cnode 1654 is 1655 Res : O_Cnode; 1656 V : Integer_64; 1657 begin 1658 if Token_Number = Unsigned_64 (Integer_64'Last) + 1 then 1659 V := Integer_64'First; 1660 else 1661 V := -Integer_64 (Token_Number); 1662 end if; 1663 Res := New_Signed_Literal (Atype.Type_Onode, V); 1664 Next_Token; 1665 return Res; 1666 end Parse_Minus_Num; 1667 1668 -- Parse a literal whose type is ATYPE. 1669 function Parse_Typed_Literal (Atype : Node_Acc) return O_Cnode 1670 is 1671 Res : O_Cnode; 1672 begin 1673 case Tok is 1674 when Tok_Num => 1675 case Atype.Kind is 1676 when Type_Signed => 1677 Res := New_Signed_Literal 1678 (Atype.Type_Onode, Integer_64 (Token_Number)); 1679 when Type_Unsigned => 1680 Res := New_Unsigned_Literal 1681 (Atype.Type_Onode, Token_Number); 1682 when others => 1683 Parse_Error ("bad type for integer literal"); 1684 end case; 1685 when Tok_Minus => 1686 Next_Token; 1687 case Tok is 1688 when Tok_Num => 1689 return Parse_Minus_Num (Atype); 1690 when Tok_Float_Num => 1691 Res := New_Float_Literal (Atype.Type_Onode, -Token_Float); 1692 when others => 1693 Parse_Error ("bad token after '-'"); 1694 end case; 1695 when Tok_Float_Num => 1696 Res := New_Float_Literal (Atype.Type_Onode, Token_Float); 1697 when Tok_Ident => 1698 declare 1699 Pfx : Node_Acc; 1700 N : Node_Acc; 1701 begin 1702 -- Note: we don't use get_decl, since the name can be a literal 1703 -- name, which is not directly visible. 1704 if Token_Sym.Name /= null 1705 and then Token_Sym.Name.Inter.Kind = Decl_Type 1706 then 1707 -- A typed expression. 1708 Pfx := Token_Sym.Name.Inter; 1709 N := Pfx.Decl_Dtype; 1710 if Atype /= null and then N /= Atype then 1711 Parse_Error ("type mismatch"); 1712 end if; 1713 Next_Expect (Tok_Tick); 1714 Next_Token; 1715 if Tok = Tok_Left_Brack then 1716 Next_Token; 1717 Res := Parse_Typed_Literal (N); 1718 Expect (Tok_Right_Brack); 1719 elsif Tok = Tok_Ident then 1720 if Token_Sym = Id_Offsetof then 1721 Res := Parse_Offsetof (N); 1722 elsif Token_Sym = Id_Sizeof then 1723 Res := Parse_Sizeof (N); 1724 elsif Token_Sym = Id_Record_Sizeof then 1725 Res := Parse_Record_Sizeof (N); 1726 elsif Token_Sym = Id_Alignof then 1727 Res := Parse_Alignof (N); 1728 elsif Token_Sym = Id_Address 1729 or Token_Sym = Id_Unchecked_Address 1730 or Token_Sym = Id_Subprg_Addr 1731 then 1732 Res := Parse_Constant_Address (Pfx); 1733 elsif Token_Sym = Id_Conv then 1734 Next_Expect (Tok_Left_Paren); 1735 Next_Token; 1736 Res := Parse_Typed_Literal (N); 1737 Expect (Tok_Right_Paren); 1738 else 1739 Parse_Error ("offsetof or sizeof attributes expected"); 1740 end if; 1741 else 1742 Parse_Error ("'[' or attribute expected"); 1743 end if; 1744 else 1745 if Atype.Kind /= Type_Enum 1746 and then Atype.Kind /= Type_Boolean 1747 then 1748 Parse_Error ("name allowed only for enumeration"); 1749 end if; 1750 N := Atype.Enum_Lits; 1751 while N /= null loop 1752 if Is_Equal (N.Lit_Name, Token_Sym.Ident) then 1753 Res := N.Lit_Cnode; 1754 exit; 1755 end if; 1756 N := N.Lit_Next; 1757 end loop; 1758 if N = null then 1759 Parse_Error ("no matching literal"); 1760 return O_Cnode_Null; 1761 end if; 1762 end if; 1763 end; 1764 when Tok_Null => 1765 Res := New_Null_Access (Atype.Type_Onode); 1766 when Tok_Default => 1767 Res := New_Default_Value (Atype.Type_Onode); 1768 when others => 1769 Parse_Error ("bad primary expression: " & Token_Type'Image (Tok)); 1770 return O_Cnode_Null; 1771 end case; 1772 Next_Token; 1773 return Res; 1774 end Parse_Typed_Literal; 1775 1776 -- expect: next token 1777 -- Parse an expression starting with NAME. 1778 procedure Parse_Named_Expression 1779 (Atype : Node_Acc; Name : Node_Acc; Stop_At_All : Boolean; 1780 Res : out O_Enode; 1781 Res_Type : out Node_Acc) 1782 is 1783 begin 1784 if Tok = Tok_Tick then 1785 Next_Token; 1786 if Tok = Tok_Left_Brack then 1787 -- Typed literal. 1788 Next_Token; 1789 Res := New_Lit (Parse_Typed_Literal (Name.Decl_Dtype)); 1790 Res_Type := Name.Decl_Dtype; 1791 Expect (Tok_Right_Brack); 1792 Next_Token; 1793 elsif Tok = Tok_Left_Paren then 1794 -- Typed expression (used for comparaison operators) 1795 Next_Token; 1796 Parse_Expression (Name.Decl_Dtype, Res, Res_Type); 1797 Expect (Tok_Right_Paren); 1798 Next_Token; 1799 elsif Tok = Tok_Ident then 1800 -- Attribute. 1801 if Token_Sym = Id_Conv then 1802 declare 1803 Ov : Boolean; 1804 begin 1805 Next_Token; 1806 if Tok = Tok_Sharp then 1807 Ov := True; 1808 Next_Token; 1809 else 1810 Ov := False; 1811 end if; 1812 Expect (Tok_Left_Paren); 1813 Next_Token; 1814 Parse_Expression (null, Res, Res_Type); 1815 -- Discard Res_Type. 1816 Expect (Tok_Right_Paren); 1817 Next_Token; 1818 Res_Type := Name.Decl_Dtype; 1819 if Ov then 1820 Res := New_Convert_Ov (Res, Res_Type.Type_Onode); 1821 else 1822 Res := New_Convert (Res, Res_Type.Type_Onode); 1823 end if; 1824 -- Fall-through. 1825 end; 1826 elsif Token_Sym = Id_Address 1827 or Token_Sym = Id_Unchecked_Address 1828 or Token_Sym = Id_Subprg_Addr 1829 then 1830 Res_Type := Name.Decl_Dtype; 1831 Res := Parse_Address (Name); 1832 -- Fall-through. 1833 elsif Token_Sym = Id_Sizeof then 1834 Res_Type := Name.Decl_Dtype; 1835 Res := New_Lit (Parse_Sizeof (Res_Type)); 1836 Next_Token; 1837 return; 1838 elsif Token_Sym = Id_Record_Sizeof then 1839 Res_Type := Name.Decl_Dtype; 1840 Res := New_Lit (Parse_Record_Sizeof (Res_Type)); 1841 Next_Token; 1842 return; 1843 elsif Token_Sym = Id_Alignof then 1844 Res_Type := Name.Decl_Dtype; 1845 Res := New_Lit (Parse_Alignof (Res_Type)); 1846 Next_Token; 1847 return; 1848 elsif Token_Sym = Id_Alloca then 1849 Next_Expect (Tok_Left_Paren); 1850 Next_Token; 1851 Parse_Expression (null, Res, Res_Type); 1852 -- Discard Res_Type. 1853 Res_Type := Name.Decl_Dtype; 1854 Res := New_Alloca (Res_Type.Type_Onode, Res); 1855 Expect (Tok_Right_Paren); 1856 Next_Token; 1857 return; 1858 elsif Token_Sym = Id_Offsetof then 1859 Res_Type := Atype; 1860 Res := New_Lit (Parse_Offsetof (Res_Type)); 1861 Next_Token; 1862 return; 1863 else 1864 Parse_Error ("unknown attribute name"); 1865 end if; 1866 -- Fall-through. 1867 else 1868 Parse_Error ("typed expression expected"); 1869 end if; 1870 elsif Tok = Tok_Left_Paren then 1871 if Name.Kind /= Node_Function then 1872 Parse_Error ("function name expected"); 1873 end if; 1874 declare 1875 Constr : O_Assoc_List; 1876 begin 1877 Parse_Association (Constr, Name); 1878 Res := New_Function_Call (Constr); 1879 Res_Type := Name.Decl_Dtype; 1880 -- Fall-through. 1881 end; 1882 elsif Name.Kind = Node_Object 1883 or else Name.Kind = Decl_Param 1884 then 1885 -- Name. 1886 declare 1887 Lval : O_Lnode; 1888 begin 1889 Parse_Name (Name, Lval, Res_Type); 1890 Res := New_Value (Lval); 1891 if Atype /= null and then Res_Type /= Atype then 1892 Parse_Error ("type mismatch"); 1893 end if; 1894 end; 1895 else 1896 Parse_Error ("bad ident expression: " 1897 & Token_Type'Image (Tok)); 1898 end if; 1899 1900 -- Continue. 1901 -- R_TYPE and RES must be set. 1902 if Tok = Tok_Dot then 1903 if Stop_At_All then 1904 return; 1905 end if; 1906 Next_Token; 1907 if Tok = Tok_All then 1908 if Res_Type.Kind /= Type_Access then 1909 Parse_Error ("type of prefix is not an access"); 1910 end if; 1911 declare 1912 N : O_Lnode; 1913 begin 1914 Next_Token; 1915 N := New_Access_Element (Res); 1916 Res_Type := Res_Type.Access_Dtype; 1917 Parse_Lvalue (N, Res_Type); 1918 Res := New_Value (N); 1919 end; 1920 return; 1921 else 1922 Parse_Error ("'.all' expected"); 1923 end if; 1924 end if; 1925 end Parse_Named_Expression; 1926 1927 procedure Parse_Primary_Expression (Atype : Node_Acc; 1928 Res : out O_Enode; 1929 Res_Type : out Node_Acc) 1930 is 1931 begin 1932 case Tok is 1933 when Tok_Num 1934 | Tok_Float_Num => 1935 if Atype = null then 1936 Parse_Error ("numeric literal without type context"); 1937 end if; 1938 Res_Type := Atype; 1939 Res := New_Lit (Parse_Typed_Literal (Atype)); 1940 when Tok_Ident => 1941 declare 1942 N : Node_Acc; 1943 begin 1944 N := Get_Decl (Token_Sym); 1945 Next_Token; 1946 Parse_Named_Expression (Atype, N, False, Res, Res_Type); 1947 end; 1948 when Tok_Left_Paren => 1949 Next_Token; 1950 Parse_Expression (Atype, Res, Res_Type); 1951 Expect (Tok_Right_Paren); 1952 Next_Token; 1953 when others => 1954 Parse_Error ("bad primary expression: " & Token_Type'Image (Tok)); 1955 end case; 1956 end Parse_Primary_Expression; 1957 1958 -- Parse '-' EXPR, 'not' EXPR, 'abs' EXPR or EXPR. 1959 procedure Parse_Unary_Expression (Atype : Node_Acc; 1960 Res : out O_Enode; 1961 Res_Type : out Node_Acc) is 1962 begin 1963 case Tok is 1964 when Tok_Minus => 1965 Next_Token; 1966 if Tok = Tok_Num then 1967 if Atype = null then 1968 Parse_Error ("numeric literal without type context"); 1969 end if; 1970 Res := New_Lit (Parse_Minus_Num (Atype)); 1971 Res_Type := Atype; 1972 else 1973 Parse_Unary_Expression (Atype, Res, Res_Type); 1974 Res := New_Monadic_Op (ON_Neg_Ov, Res); 1975 end if; 1976 when Tok_Not => 1977 Next_Token; 1978 Parse_Unary_Expression (Atype, Res, Res_Type); 1979 Res := New_Monadic_Op (ON_Not, Res); 1980 when Tok_Abs => 1981 Next_Token; 1982 Parse_Unary_Expression (Atype, Res, Res_Type); 1983 Res := New_Monadic_Op (ON_Abs_Ov, Res); 1984 when others => 1985 Parse_Primary_Expression (Atype, Res, Res_Type); 1986 end case; 1987 end Parse_Unary_Expression; 1988 1989 function Check_Sharp (Op_Ov : ON_Op_Kind) return ON_Op_Kind is 1990 begin 1991 Next_Expect (Tok_Sharp); 1992 Next_Token; 1993 return Op_Ov; 1994 end Check_Sharp; 1995 1996 procedure Parse_Expression (Expr_Type : Node_Acc; 1997 Expr : out O_Enode; 1998 Res_Type : out Node_Acc) 1999 is 2000 Op_Type : Node_Acc; 2001 L : O_Enode; 2002 R : O_Enode; 2003 Op : ON_Op_Kind; 2004 begin 2005 if Expr_Type = null or else Expr_Type.Kind = Type_Boolean then 2006 -- The type of the expression isn't known, as this can be a 2007 -- comparaison operator. 2008 Op_Type := null; 2009 else 2010 Op_Type := Expr_Type; 2011 end if; 2012 Parse_Unary_Expression (Op_Type, L, Res_Type); 2013 case Tok is 2014 when Tok_Div => 2015 Op := Check_Sharp (ON_Div_Ov); 2016 when Tok_Plus => 2017 Op := Check_Sharp (ON_Add_Ov); 2018 when Tok_Minus => 2019 Op := Check_Sharp (ON_Sub_Ov); 2020 when Tok_Star => 2021 Op := Check_Sharp (ON_Mul_Ov); 2022 when Tok_Mod => 2023 Op := Check_Sharp (ON_Mod_Ov); 2024 when Tok_Rem => 2025 Op := Check_Sharp (ON_Rem_Ov); 2026 2027 when Tok_Equal => 2028 Op := ON_Eq; 2029 when Tok_Not_Equal => 2030 Op := ON_Neq; 2031 when Tok_Greater => 2032 Op := ON_Gt; 2033 when Tok_Greater_Eq => 2034 Op := ON_Ge; 2035 when Tok_Less => 2036 Op := ON_Lt; 2037 when Tok_Less_Eq => 2038 Op := ON_Le; 2039 2040 when Tok_Or => 2041 Op := ON_Or; 2042 Next_Token; 2043 when Tok_And => 2044 Op := ON_And; 2045 Next_Token; 2046 when Tok_Xor => 2047 Op := ON_Xor; 2048 Next_Token; 2049 2050 when others => 2051 Expr := L; 2052 return; 2053 end case; 2054 if Op in ON_Compare_Op_Kind then 2055 Next_Token; 2056 end if; 2057 2058 Parse_Unary_Expression (Res_Type, R, Res_Type); 2059 case Op is 2060 when ON_Dyadic_Op_Kind => 2061 Expr := New_Dyadic_Op (Op, L, R); 2062 when ON_Compare_Op_Kind => 2063 if Expr_Type = null then 2064 Parse_Error ("comparaison operator requires a type"); 2065 end if; 2066 Expr := New_Compare_Op (Op, L, R, Expr_Type.Type_Onode); 2067 Res_Type := Expr_Type; 2068 when others => 2069 raise Program_Error; 2070 end case; 2071 end Parse_Expression; 2072 2073 procedure Check_Selected_Prefix (N_Type : Node_Acc) is 2074 begin 2075 case N_Type.Kind is 2076 when Type_Record 2077 | Type_Union 2078 | Type_Subrecord => 2079 null; 2080 when others => 2081 Parse_Error ("type of prefix is neither a record nor an union"); 2082 end case; 2083 end Check_Selected_Prefix; 2084 2085 -- Expect and leave: next token 2086 procedure Parse_Lvalue (N : in out O_Lnode; N_Type : in out Node_Acc) is 2087 begin 2088 loop 2089 case Tok is 2090 when Tok_Dot => 2091 Next_Token; 2092 if Tok = Tok_All then 2093 if N_Type.Kind /= Type_Access then 2094 Parse_Error ("type of prefix is not an access"); 2095 end if; 2096 N := New_Access_Element (New_Value (N)); 2097 N_Type := N_Type.Access_Dtype; 2098 Next_Token; 2099 elsif Tok = Tok_Ident then 2100 Check_Selected_Prefix (N_Type); 2101 declare 2102 Field : Node_Acc; 2103 begin 2104 Field := Find_Field_By_Name (N_Type); 2105 N := New_Selected_Element (N, Field.Field_Fnode); 2106 N_Type := Field.Field_Type; 2107 Next_Token; 2108 end; 2109 else 2110 Parse_Error 2111 ("'.' must be followed by 'all' or a field name"); 2112 end if; 2113 when Tok_Left_Brack => 2114 declare 2115 V : O_Enode; 2116 Bt : Node_Acc; 2117 Res_Type : Node_Acc; 2118 begin 2119 Next_Token; 2120 if N_Type.Kind = Type_Subarray then 2121 Bt := N_Type.Subarray_Base; 2122 else 2123 Bt := N_Type; 2124 end if; 2125 if Bt.Kind /= Type_Array then 2126 Parse_Error ("type of prefix is not an array"); 2127 end if; 2128 Parse_Expression (Bt.Array_Index, V, Res_Type); 2129 if Tok = Tok_Elipsis then 2130 N := New_Slice (N, Bt.Type_Onode, V); 2131 Next_Token; 2132 else 2133 N := New_Indexed_Element (N, V); 2134 N_Type := Bt.Array_Element; 2135 end if; 2136 Expect (Tok_Right_Brack); 2137 Next_Token; 2138 end; 2139 when others => 2140 return; 2141 end case; 2142 end loop; 2143 end Parse_Lvalue; 2144 2145 procedure Parse_Name (Prefix : Node_Acc; 2146 Name : out O_Lnode; N_Type : out Node_Acc) 2147 is 2148 begin 2149 case Prefix.Kind is 2150 when Decl_Param => 2151 Name := New_Obj (Prefix.Param_Node); 2152 N_Type := Prefix.Decl_Dtype; 2153 when Node_Object => 2154 Name := New_Obj (Prefix.Obj_Node); 2155 N_Type := Prefix.Decl_Dtype; 2156 when Decl_Type => 2157 declare 2158 Val : O_Enode; 2159 begin 2160 Parse_Named_Expression (null, Prefix, True, Val, N_Type); 2161 if N_Type /= Prefix.Decl_Dtype then 2162 Parse_Error ("type doesn't match"); 2163 end if; 2164 if Tok = Tok_Dot then 2165 Next_Token; 2166 if Tok = Tok_All then 2167 if N_Type.Kind /= Type_Access then 2168 Parse_Error ("type of prefix is not an access"); 2169 end if; 2170 Name := New_Access_Element (Val); 2171 N_Type := N_Type.Access_Dtype; 2172 Next_Token; 2173 else 2174 Parse_Error ("'.all' expected"); 2175 end if; 2176 else 2177 Parse_Error ("name expected"); 2178 end if; 2179 end; 2180 when others => 2181 Parse_Error ("invalid name"); 2182 end case; 2183 Parse_Lvalue (Name, N_Type); 2184 end Parse_Name; 2185 2186 -- Expect: '(' 2187 -- Let: next token. 2188 procedure Parse_Association (Constr : in out O_Assoc_List; Decl : Node_Acc) 2189 is 2190 Param : Node_Acc; 2191 Expr : O_Enode; 2192 Expr_Type : Node_Acc; 2193 begin 2194 Start_Association (Constr, Decl.Subprg_Node); 2195 if Tok /= Tok_Left_Paren then 2196 Parse_Error ("'(' expected for a subprogram call"); 2197 end if; 2198 Next_Token; 2199 Param := Decl.Subprg_Params; 2200 while Tok /= Tok_Right_Paren loop 2201 if Param = null then 2202 Parse_Error ("too many parameters"); 2203 end if; 2204 Parse_Expression (Param.Decl_Dtype, Expr, Expr_Type); 2205 New_Association (Constr, Expr); 2206 Param := Param.Param_Next; 2207 exit when Tok /= Tok_Comma; 2208 Next_Token; 2209 end loop; 2210 if Param /= null then 2211 Parse_Error ("missing parameters"); 2212 end if; 2213 if Tok /= Tok_Right_Paren then 2214 Parse_Error ("')' expected to finish a subprogram call, found " 2215 & Token_Type'Image (Tok)); 2216 end if; 2217 Next_Token; 2218 end Parse_Association; 2219 2220 type Loop_Info; 2221 type Loop_Info_Acc is access Loop_Info; 2222 type Loop_Info is record 2223 Num : Natural; 2224 Blk : O_Snode; 2225 Prev : Loop_Info_Acc; 2226 end record; 2227 procedure Free is new Ada.Unchecked_Deallocation 2228 (Name => Loop_Info_Acc, Object => Loop_Info); 2229 2230 Loop_Stack : Loop_Info_Acc := null; 2231 2232 function Find_Loop (N : Natural) return Loop_Info_Acc 2233 is 2234 Res : Loop_Info_Acc; 2235 begin 2236 Res := Loop_Stack; 2237 while Res /= null loop 2238 if Res.Num = N then 2239 return Res; 2240 end if; 2241 Res := Res.Prev; 2242 end loop; 2243 return null; 2244 end Find_Loop; 2245 2246 Current_Subprg : Node_Acc := null; 2247 2248 procedure Parse_Statement; 2249 2250 -- Expect : next token 2251 -- Let: next token 2252 procedure Parse_Statements is 2253 begin 2254 loop 2255 exit when Tok = Tok_End; 2256 exit when Tok = Tok_Else; 2257 exit when Tok = Tok_When; 2258 Parse_Statement; 2259 end loop; 2260 end Parse_Statements; 2261 2262 -- Expect : next token 2263 -- Let: next token 2264 procedure Parse_Statement is 2265 begin 2266 if Flag_Renumber then 2267 New_Debug_Line_Stmt (Lineno); 2268 end if; 2269 2270 case Tok is 2271 when Tok_Comment => 2272 Next_Token; 2273 2274 when Tok_Declare => 2275 Start_Declare_Stmt; 2276 Parse_Compound_Statement; 2277 Expect (Tok_Semicolon); 2278 Next_Token; 2279 Finish_Declare_Stmt; 2280 2281 when Tok_Line_Number => 2282 Next_Expect (Tok_Num); 2283 if Flag_Renumber = False then 2284 New_Debug_Line_Stmt (Natural (Token_Number)); 2285 end if; 2286 Next_Token; 2287 2288 when Tok_If => 2289 declare 2290 If_Blk : O_If_Block; 2291 Cond : O_Enode; 2292 Cond_Type : Node_Acc; 2293 begin 2294 Next_Token; 2295 Parse_Expression (null, Cond, Cond_Type); 2296 Start_If_Stmt (If_Blk, Cond); 2297 Expect (Tok_Then); 2298 Next_Token; 2299 Parse_Statements; 2300 if Tok = Tok_Else then 2301 Next_Token; 2302 New_Else_Stmt (If_Blk); 2303 Parse_Statements; 2304 end if; 2305 Finish_If_Stmt (If_Blk); 2306 Expect (Tok_End); 2307 Next_Expect (Tok_If); 2308 Next_Expect (Tok_Semicolon); 2309 Next_Token; 2310 end; 2311 2312 when Tok_Loop => 2313 -- Grammar: 2314 -- LOOP n: 2315 -- stmts 2316 -- END LOOP; 2317 declare 2318 Info : Loop_Info_Acc; 2319 Num : Natural; 2320 begin 2321 Next_Expect (Tok_Num); 2322 Num := Natural (Token_Number); 2323 if Find_Loop (Num) /= null then 2324 Parse_Error ("loop label already defined"); 2325 end if; 2326 Info := new Loop_Info; 2327 Info.Num := Num; 2328 Info.Prev := Loop_Stack; 2329 Loop_Stack := Info; 2330 Start_Loop_Stmt (Info.Blk); 2331 Next_Expect (Tok_Colon); 2332 Next_Token; 2333 Parse_Statements; 2334 Finish_Loop_Stmt (Info.Blk); 2335 Next_Expect (Tok_Loop); 2336 Next_Expect (Tok_Semicolon); 2337 Loop_Stack := Info.Prev; 2338 Free (Info); 2339 Next_Token; 2340 end; 2341 2342 when Tok_Exit 2343 | Tok_Next => 2344 -- Grammar: 2345 -- EXIT LOOP n; 2346 -- NEXT LOOP n; 2347 declare 2348 Label : Loop_Info_Acc; 2349 Etok : Token_Type; 2350 begin 2351 Etok := Tok; 2352 Next_Expect (Tok_Loop); 2353 Next_Expect (Tok_Num); 2354 Label := Find_Loop (Natural (Token_Number)); 2355 if Label = null then 2356 Parse_Error ("no such loop"); 2357 end if; 2358 if Etok = Tok_Exit then 2359 New_Exit_Stmt (Label.Blk); 2360 else 2361 New_Next_Stmt (Label.Blk); 2362 end if; 2363 Next_Expect (Tok_Semicolon); 2364 Next_Token; 2365 end; 2366 2367 when Tok_Return => 2368 -- Grammar: 2369 -- RETURN; 2370 -- RETURN expr; 2371 declare 2372 Res : O_Enode; 2373 Res_Type : Node_Acc; 2374 begin 2375 Next_Token; 2376 if Tok /= Tok_Semicolon then 2377 Parse_Expression (Current_Subprg.Decl_Dtype, Res, Res_Type); 2378 New_Return_Stmt (Res); 2379 if Tok /= Tok_Semicolon then 2380 Parse_Error ("';' expected at end of return statement"); 2381 end if; 2382 else 2383 New_Return_Stmt; 2384 end if; 2385 Next_Token; 2386 end; 2387 2388 when Tok_Ident => 2389 -- This is either a procedure call or an assignment. 2390 declare 2391 Inter : Node_Acc; 2392 begin 2393 Inter := Get_Decl (Token_Sym); 2394 Next_Token; 2395 if Tok = Tok_Left_Paren then 2396 -- A procedure call. 2397 declare 2398 Constr : O_Assoc_List; 2399 begin 2400 Parse_Association (Constr, Inter); 2401 New_Procedure_Call (Constr); 2402 if Tok /= Tok_Semicolon then 2403 Parse_Error ("';' expected after call"); 2404 end if; 2405 Next_Token; 2406 return; 2407 end; 2408 else 2409 -- An assignment. 2410 declare 2411 Name : O_Lnode; 2412 Expr : O_Enode; 2413 Expr_Type : Node_Acc; 2414 N_Type : Node_Acc; 2415 begin 2416 Parse_Name (Inter, Name, N_Type); 2417 if Tok /= Tok_Assign then 2418 Parse_Error ("`:=' expected after a variable"); 2419 end if; 2420 Next_Token; 2421 Parse_Expression (N_Type, Expr, Expr_Type); 2422 New_Assign_Stmt (Name, Expr); 2423 if Tok /= Tok_Semicolon then 2424 Parse_Error ("';' expected at end of assignment"); 2425 end if; 2426 Next_Token; 2427 return; 2428 end; 2429 end if; 2430 end; 2431 2432 when Tok_Case => 2433 -- Grammar: 2434 -- CASE expr IS 2435 -- WHEN lit => 2436 -- WHEN lit ... lit => 2437 -- WHEN DEFAULT => 2438 -- END CASE; 2439 declare 2440 Case_Blk : O_Case_Block; 2441 L : O_Cnode; 2442 Choice : O_Enode; 2443 Choice_Type : Node_Acc; 2444 begin 2445 Next_Token; 2446 Parse_Expression (null, Choice, Choice_Type); 2447 Start_Case_Stmt (Case_Blk, Choice); 2448 Expect (Tok_Is); 2449 Next_Token; 2450 loop 2451 exit when Tok = Tok_End; 2452 Expect (Tok_When); 2453 Next_Token; 2454 Start_Choice (Case_Blk); 2455 loop 2456 if Tok = Tok_Default then 2457 New_Default_Choice (Case_Blk); 2458 Next_Token; 2459 else 2460 L := Parse_Typed_Literal (Choice_Type); 2461 if Tok = Tok_Elipsis then 2462 Next_Token; 2463 New_Range_Choice 2464 (Case_Blk, L, Parse_Typed_Literal (Choice_Type)); 2465 else 2466 New_Expr_Choice (Case_Blk, L); 2467 end if; 2468 end if; 2469 exit when Tok = Tok_Arrow; 2470 Expect (Tok_Comma); 2471 Next_Token; 2472 end loop; 2473 -- Skip '=>'. 2474 Next_Token; 2475 Finish_Choice (Case_Blk); 2476 Parse_Statements; 2477 end loop; 2478 Finish_Case_Stmt (Case_Blk); 2479 Expect (Tok_End); 2480 Next_Expect (Tok_Case); 2481 Next_Expect (Tok_Semicolon); 2482 Next_Token; 2483 end; 2484 when others => 2485 Parse_Error ("bad statement: " & Token_Type'Image (Tok)); 2486 end case; 2487 end Parse_Statement; 2488 2489 procedure Parse_Compound_Statement is 2490 begin 2491 if Tok /= Tok_Declare then 2492 Parse_Error ("'declare' expected to start a statements block"); 2493 end if; 2494 Next_Token; 2495 2496 Push_Scope; 2497 2498 -- Parse declarations. 2499 while Tok /= Tok_Begin loop 2500 Parse_Declaration; 2501 end loop; 2502 Next_Token; 2503 2504 -- Parse statements. 2505 Parse_Statements; 2506 Expect (Tok_End); 2507 Next_Token; 2508 2509 Pop_Scope; 2510 end Parse_Compound_Statement; 2511 2512 -- Parse (P1 : T1; P2: T2; ...) 2513 function Parse_Parameter_List return Node_Acc 2514 is 2515 First, Last : Node_Acc; 2516 P : Node_Acc; 2517 begin 2518 Expect (Tok_Left_Paren); 2519 Next_Token; 2520 if Tok = Tok_Right_Paren then 2521 Next_Token; 2522 return null; 2523 end if; 2524 First := null; 2525 Last := null; 2526 loop 2527 Expect (Tok_Ident); 2528 P := new Node'(Kind => Decl_Param, 2529 Decl_Dtype => null, 2530 Decl_Storage => O_Storage_Public, 2531 Decl_Defined => False, 2532 Param_Node => O_Dnode_Null, 2533 Param_Name => Token_Sym, 2534 Param_Next => null); 2535 -- Link 2536 if Last = null then 2537 First := P; 2538 else 2539 Last.Param_Next := P; 2540 end if; 2541 Last := P; 2542 Next_Expect (Tok_Colon); 2543 Next_Token; 2544 P.Decl_Dtype := Parse_Type; 2545 exit when Tok = Tok_Right_Paren; 2546 Expect (Tok_Semicolon); 2547 Next_Token; 2548 end loop; 2549 Next_Token; 2550 return First; 2551 end Parse_Parameter_List; 2552 2553 procedure Create_Interface_List (Constr : in out O_Inter_List; 2554 First_Inter : Node_Acc) 2555 is 2556 Inter : Node_Acc; 2557 begin 2558 Inter := First_Inter; 2559 while Inter /= null loop 2560 New_Interface_Decl (Constr, Inter.Param_Node, Inter.Param_Name.Ident, 2561 Inter.Decl_Dtype.Type_Onode); 2562 Inter := Inter.Param_Next; 2563 end loop; 2564 end Create_Interface_List; 2565 2566 procedure Check_Parameter_List (List : Node_Acc) 2567 is 2568 Param : Node_Acc; 2569 begin 2570 Next_Expect (Tok_Left_Paren); 2571 Next_Token; 2572 Param := List; 2573 while Tok /= Tok_Right_Paren loop 2574 if Param = null then 2575 Parse_Error ("subprogram redefined with more parameters"); 2576 end if; 2577 Expect (Tok_Ident); 2578 if Token_Sym /= Param.Param_Name then 2579 Parse_Error ("subprogram redefined with different parameter name"); 2580 end if; 2581 Next_Expect (Tok_Colon); 2582 Next_Token; 2583 if Parse_Type /= Param.Decl_Dtype then 2584 Parse_Error ("subprogram redefined with different parameter type"); 2585 end if; 2586 Param := Param.Param_Next; 2587 exit when Tok = Tok_Right_Paren; 2588 Expect (Tok_Semicolon); 2589 Next_Token; 2590 end loop; 2591 Expect (Tok_Right_Paren); 2592 Next_Token; 2593 if Param /= null then 2594 Parse_Error ("subprogram redefined with less parameters"); 2595 end if; 2596 end Check_Parameter_List; 2597 2598 procedure Parse_Subprogram_Body (Subprg : Node_Acc) 2599 is 2600 Param : Node_Acc; 2601 Prev_Subprg : Node_Acc; 2602 begin 2603 Prev_Subprg := Current_Subprg; 2604 Current_Subprg := Subprg; 2605 2606 Start_Subprogram_Body (Subprg.Subprg_Node); 2607 Push_Scope; 2608 2609 -- Put parameters in the current scope. 2610 Param := Subprg.Subprg_Params; 2611 while Param /= null loop 2612 Add_Decl (Param.Param_Name, Param); 2613 Param := Param.Param_Next; 2614 end loop; 2615 2616 Parse_Compound_Statement; 2617 2618 Pop_Scope; 2619 Finish_Subprogram_Body; 2620 2621 Current_Subprg := Prev_Subprg; 2622 end Parse_Subprogram_Body; 2623 2624 procedure Parse_Function_Definition (Storage : O_Storage) 2625 is 2626 Constr : O_Inter_List; 2627 Sym : Syment_Acc; 2628 N : Node_Acc; 2629 begin 2630 Expect (Tok_Function); 2631 Next_Expect (Tok_Ident); 2632 Sym := Token_Sym; 2633 if Sym.Name /= null then 2634 N := Get_Decl (Sym); 2635 Check_Parameter_List (N.Subprg_Params); 2636 Expect (Tok_Return); 2637 Next_Expect (Tok_Ident); 2638 Next_Token; 2639 else 2640 N := new Node'(Kind => Node_Function, 2641 Decl_Dtype => null, 2642 Decl_Storage => Storage, 2643 Decl_Defined => False, 2644 Subprg_Node => O_Dnode_Null, 2645 Subprg_Name => Sym, 2646 Subprg_Params => null); 2647 Next_Token; 2648 N.Subprg_Params := Parse_Parameter_List; 2649 Expect (Tok_Return); 2650 Next_Token; 2651 N.Decl_Dtype := Parse_Type; 2652 2653 Start_Function_Decl (Constr, N.Subprg_Name.Ident, Storage, 2654 N.Decl_Dtype.Type_Onode); 2655 Create_Interface_List (Constr, N.Subprg_Params); 2656 Finish_Subprogram_Decl (Constr, N.Subprg_Node); 2657 2658 Add_Decl (Sym, N); 2659 end if; 2660 2661 if Tok = Tok_Declare then 2662 Parse_Subprogram_Body (N); 2663 end if; 2664 end Parse_Function_Definition; 2665 2666 procedure Parse_Procedure_Definition (Storage : O_Storage) 2667 is 2668 Constr : O_Inter_List; 2669 Sym : Syment_Acc; 2670 N : Node_Acc; 2671 begin 2672 Expect (Tok_Procedure); 2673 Next_Expect (Tok_Ident); 2674 Sym := Token_Sym; 2675 if Sym.Name /= null then 2676 N := Get_Decl (Sym); 2677 Check_Parameter_List (N.Subprg_Params); 2678 else 2679 N := new Node'(Kind => Node_Procedure, 2680 Decl_Dtype => null, 2681 Decl_Storage => Storage, 2682 Decl_Defined => False, 2683 Subprg_Node => O_Dnode_Null, 2684 Subprg_Name => Sym, 2685 Subprg_Params => null); 2686 Next_Token; 2687 N.Subprg_Params := Parse_Parameter_List; 2688 2689 Start_Procedure_Decl (Constr, N.Subprg_Name.Ident, Storage); 2690 Create_Interface_List (Constr, N.Subprg_Params); 2691 Finish_Subprogram_Decl (Constr, N.Subprg_Node); 2692 2693 Add_Decl (Sym, N); 2694 end if; 2695 2696 if Tok = Tok_Declare then 2697 Parse_Subprogram_Body (N); 2698 end if; 2699 end Parse_Procedure_Definition; 2700 2701 function Parse_Address (Prefix : Node_Acc) return O_Enode 2702 is 2703 Pfx : Node_Acc; 2704 N : O_Lnode; 2705 N_Type : Node_Acc; 2706 Res : O_Enode; 2707 Attr : Syment_Acc; 2708 T : O_Tnode; 2709 begin 2710 Attr := Token_Sym; 2711 Next_Expect (Tok_Left_Paren); 2712 Next_Expect (Tok_Ident); 2713 Pfx := Get_Decl (Token_Sym); 2714 T := Prefix.Decl_Dtype.Type_Onode; 2715 if Attr = Id_Subprg_Addr then 2716 Expect (Tok_Ident); 2717 Pfx := Get_Decl (Token_Sym); 2718 if Pfx.Kind not in Nodes_Subprogram then 2719 Parse_Error ("subprogram identifier expected"); 2720 end if; 2721 Res := New_Lit (New_Subprogram_Address (Pfx.Subprg_Node, T)); 2722 Next_Token; 2723 else 2724 Next_Token; 2725 Parse_Name (Pfx, N, N_Type); 2726 if Attr = Id_Address then 2727 Res := New_Address (N, T); 2728 elsif Attr = Id_Unchecked_Address then 2729 Res := New_Unchecked_Address (N, T); 2730 else 2731 Parse_Error ("address attribute expected"); 2732 end if; 2733 end if; 2734 Expect (Tok_Right_Paren); 2735 Next_Token; 2736 return Res; 2737 end Parse_Address; 2738 2739 procedure Parse_Global_Name (Prefix : Node_Acc; 2740 Name : out O_Gnode; N_Type : out Node_Acc) 2741 is 2742 begin 2743 case Prefix.Kind is 2744 when Node_Object => 2745 Name := New_Global (Prefix.Obj_Node); 2746 N_Type := Prefix.Decl_Dtype; 2747 when others => 2748 Parse_Error ("invalid name"); 2749 end case; 2750 2751 loop 2752 case Tok is 2753 when Tok_Dot => 2754 Next_Token; 2755 if Tok = Tok_Ident then 2756 Check_Selected_Prefix (N_Type); 2757 declare 2758 Field : Node_Acc; 2759 begin 2760 Field := Find_Field_By_Name (N_Type); 2761 Name := New_Global_Selected_Element (Name, 2762 Field.Field_Fnode); 2763 N_Type := Field.Field_Type; 2764 Next_Token; 2765 end; 2766 else 2767 Parse_Error ("'.' must be followed by a field name"); 2768 end if; 2769 when others => 2770 return; 2771 end case; 2772 end loop; 2773 end Parse_Global_Name; 2774 2775 function Parse_Constant_Address (Prefix : Node_Acc) return O_Cnode 2776 is 2777 Pfx : Node_Acc; 2778 Res : O_Cnode; 2779 Attr : Syment_Acc; 2780 T : O_Tnode; 2781 N : O_Gnode; 2782 N_Type : Node_Acc; 2783 begin 2784 Attr := Token_Sym; 2785 Next_Expect (Tok_Left_Paren); 2786 Next_Expect (Tok_Ident); 2787 Pfx := Get_Decl (Token_Sym); 2788 T := Prefix.Decl_Dtype.Type_Onode; 2789 if Attr = Id_Subprg_Addr then 2790 Expect (Tok_Ident); 2791 Pfx := Get_Decl (Token_Sym); 2792 if Pfx.Kind not in Nodes_Subprogram then 2793 Parse_Error ("subprogram identifier expected"); 2794 end if; 2795 Res := New_Subprogram_Address (Pfx.Subprg_Node, T); 2796 Next_Token; 2797 else 2798 Next_Token; 2799 Parse_Global_Name (Pfx, N, N_Type); 2800 if Attr = Id_Address then 2801 Res := New_Global_Address (N, T); 2802 elsif Attr = Id_Unchecked_Address then 2803 Res := New_Global_Unchecked_Address (N, T); 2804 else 2805 Parse_Error ("address attribute expected"); 2806 end if; 2807 end if; 2808 Expect (Tok_Right_Paren); 2809 return Res; 2810 end Parse_Constant_Address; 2811 2812 function Parse_Array_Aggregate (Aggr_Type : Node_Acc; El_Type : Node_Acc) 2813 return O_Cnode 2814 is 2815 Res : O_Cnode; 2816 Constr : O_Array_Aggr_List; 2817 Len : Unsigned_32; 2818 begin 2819 -- Parse '[' LEN ']' 2820 Expect (Tok_Left_Brack); 2821 Next_Token; 2822 Expect (Tok_Num); 2823 Len := Unsigned_32 (Token_Number); 2824 Next_Token; 2825 Expect (Tok_Right_Brack); 2826 Next_Token; 2827 2828 Expect (Tok_Left_Brace); 2829 Next_Token; 2830 Start_Array_Aggr (Constr, Aggr_Type.Type_Onode, Len); 2831 for I in Unsigned_32 loop 2832 if Tok = Tok_Right_Brace then 2833 if I /= Len then 2834 Parse_Error ("bad number of aggregate element"); 2835 end if; 2836 exit; 2837 end if; 2838 2839 if I /= 0 then 2840 Expect (Tok_Comma); 2841 Next_Token; 2842 end if; 2843 New_Array_Aggr_El (Constr, Parse_Constant_Value (El_Type)); 2844 end loop; 2845 Finish_Array_Aggr (Constr, Res); 2846 Next_Token; 2847 return Res; 2848 end Parse_Array_Aggregate; 2849 2850 function Parse_Constant_Value (Atype : Node_Acc) return O_Cnode 2851 is 2852 Res : O_Cnode; 2853 begin 2854 case Atype.Kind is 2855 when Type_Subarray => 2856 return Parse_Array_Aggregate 2857 (Atype, Atype.Subarray_Base.Array_Element); 2858 when Type_Array => 2859 return Parse_Array_Aggregate (Atype, Atype.Array_Element); 2860 when Type_Unsigned 2861 | Type_Signed 2862 | Type_Enum 2863 | Type_Float 2864 | Type_Boolean 2865 | Type_Access => 2866 --return Parse_Primary_Expression (Atype); 2867 return Parse_Typed_Literal (Atype); 2868 when Type_Record => 2869 if Tok = Tok_Ident then 2870 -- Default value ? 2871 return Parse_Typed_Literal (Atype); 2872 end if; 2873 2874 declare 2875 Constr : O_Record_Aggr_List; 2876 Fields : Node_Array_Acc; 2877 begin 2878 Expect (Tok_Left_Brace); 2879 Next_Token; 2880 Start_Record_Aggr (Constr, Atype.Type_Onode); 2881 Fields := Atype.Record_Union_Fields; 2882 for I in Fields'Range loop 2883 if I /= 1 then 2884 Expect (Tok_Comma); 2885 Next_Token; 2886 end if; 2887 if Tok = Tok_Dot then 2888 Next_Expect (Tok_Ident); 2889 if Token_Sym /= Fields (I).Field_Ident then 2890 Parse_Error ("bad field name"); 2891 end if; 2892 Next_Expect (Tok_Equal); 2893 Next_Token; 2894 end if; 2895 New_Record_Aggr_El 2896 (Constr, Parse_Constant_Value (Fields (I).Field_Type)); 2897 end loop; 2898 Finish_Record_Aggr (Constr, Res); 2899 Expect (Tok_Right_Brace); 2900 Next_Token; 2901 return Res; 2902 end; 2903 2904 when Type_Union => 2905 if Tok = Tok_Ident then 2906 -- Default value ? 2907 return Parse_Typed_Literal (Atype); 2908 end if; 2909 declare 2910 Field : Node_Acc; 2911 begin 2912 Expect (Tok_Left_Brace); 2913 Next_Token; 2914 Expect (Tok_Dot); 2915 Next_Expect (Tok_Ident); 2916 Field := Find_Field_By_Name (Atype); 2917 Next_Expect (Tok_Equal); 2918 Next_Token; 2919 Res := New_Union_Aggr 2920 (Atype.Type_Onode, Field.Field_Fnode, 2921 Parse_Constant_Value (Field.Field_Type)); 2922 Expect (Tok_Right_Brace); 2923 Next_Token; 2924 return Res; 2925 end; 2926 when others => 2927 raise Program_Error; 2928 end case; 2929 end Parse_Constant_Value; 2930 2931 procedure Parse_Constant_Declaration (Storage : O_Storage) 2932 is 2933 N : Node_Acc; 2934 Sym : Syment_Acc; 2935 Val : O_Cnode; 2936 begin 2937 Expect (Tok_Constant); 2938 Next_Expect (Tok_Ident); 2939 Sym := Token_Sym; 2940 N := new Node'(Kind => Node_Object, 2941 Decl_Dtype => null, 2942 Decl_Storage => Storage, 2943 Decl_Defined => False, 2944 Obj_Name => Sym.Ident, 2945 Obj_Node => O_Dnode_Null); 2946 Next_Expect (Tok_Colon); 2947 Next_Token; 2948 N.Decl_Dtype := Parse_Type; 2949 New_Const_Decl (N.Obj_Node, Sym.Ident, Storage, N.Decl_Dtype.Type_Onode); 2950 Add_Decl (Sym, N); 2951 2952 if Tok = Tok_Assign then 2953 N.Decl_Defined := True; 2954 Next_Token; 2955 2956 Start_Init_Value (N.Obj_Node); 2957 Val := Parse_Constant_Value (N.Decl_Dtype); 2958 Finish_Init_Value (N.Obj_Node, Val); 2959 end if; 2960 end Parse_Constant_Declaration; 2961 2962 -- Grammar: 2963 -- CONSTANT ident := value ; 2964 procedure Parse_Constant_Value_Declaration 2965 is 2966 N : Node_Acc; 2967 Val : O_Cnode; 2968 begin 2969 Next_Expect (Tok_Ident); 2970 N := Get_Decl (Token_Sym); 2971 if N.Kind /= Node_Object then 2972 Parse_Error ("name of a constant expected"); 2973 end if; 2974 if N.Decl_Defined then 2975 Parse_Error ("constant already defined"); 2976 else 2977 N.Decl_Defined := True; 2978 end if; 2979 -- FIXME: should check storage, 2980 -- should check the object is a constant, 2981 -- should check the object has no value. 2982 Next_Expect (Tok_Assign); 2983 Next_Token; 2984 Start_Init_Value (N.Obj_Node); 2985 Val := Parse_Constant_Value (N.Decl_Dtype); 2986 Finish_Init_Value (N.Obj_Node, Val); 2987 end Parse_Constant_Value_Declaration; 2988 2989 procedure Parse_Var_Declaration (Storage : O_Storage) 2990 is 2991 N : Node_Acc; 2992 Sym : Syment_Acc; 2993 begin 2994 Expect (Tok_Var); 2995 Next_Expect (Tok_Ident); 2996 Sym := Token_Sym; 2997 N := new Node'(Kind => Node_Object, 2998 Decl_Dtype => null, 2999 Decl_Storage => Storage, 3000 Decl_Defined => False, 3001 Obj_Name => Sym.Ident, 3002 Obj_Node => O_Dnode_Null); 3003 Next_Expect (Tok_Colon); 3004 Next_Token; 3005 N.Decl_Dtype := Parse_Type; 3006 New_Var_Decl (N.Obj_Node, Sym.Ident, Storage, N.Decl_Dtype.Type_Onode); 3007 Add_Decl (Sym, N); 3008 end Parse_Var_Declaration; 3009 3010 procedure Parse_Stored_Decl (Storage : O_Storage) 3011 is 3012 begin 3013 Next_Token; 3014 if Tok = Tok_Function then 3015 Parse_Function_Definition (Storage); 3016 elsif Tok = Tok_Procedure then 3017 Parse_Procedure_Definition (Storage); 3018 elsif Tok = Tok_Constant then 3019 Parse_Constant_Declaration (Storage); 3020 elsif Tok = Tok_Var then 3021 Parse_Var_Declaration (Storage); 3022 else 3023 Parse_Error ("function or object declaration expected"); 3024 end if; 3025 end Parse_Stored_Decl; 3026 3027 procedure Parse_Declaration 3028 is 3029 Inter : Node_Acc; 3030 S : Syment_Acc; 3031 begin 3032 if Flag_Renumber then 3033 New_Debug_Line_Decl (Lineno); 3034 end if; 3035 3036 case Tok is 3037 when Tok_Type => 3038 Next_Token; 3039 if Tok /= Tok_Ident then 3040 Parse_Error ("identifier for type expected"); 3041 end if; 3042 S := Token_Sym; 3043 Next_Expect (Tok_Is); 3044 Next_Token; 3045 if Is_Defined (S) then 3046 Parse_Type_Completion (Get_Decl (S)); 3047 else 3048 Inter := new Node'(Kind => Decl_Type, 3049 Decl_Storage => O_Storage_Public, 3050 Decl_Defined => False, 3051 Decl_Dtype => Parse_Type); 3052 Add_Decl (S, Inter); 3053 New_Type_Decl (S.Ident, Inter.Decl_Dtype.Type_Onode); 3054 end if; 3055 when Tok_External => 3056 Parse_Stored_Decl (O_Storage_External); 3057 when Tok_Private => 3058 Parse_Stored_Decl (O_Storage_Private); 3059 when Tok_Public => 3060 Parse_Stored_Decl (O_Storage_Public); 3061 when Tok_Local => 3062 Parse_Stored_Decl (O_Storage_Local); 3063 when Tok_Constant => 3064 Parse_Constant_Value_Declaration; 3065 when Tok_Comment => 3066 New_Debug_Comment_Decl (Token_Ident (1 .. Token_Idlen)); 3067 Next_Token; 3068 return; 3069 when Tok_File_Name => 3070 if Flag_Renumber = False then 3071 New_Debug_Filename_Decl (Token_Ident (1 .. Token_Idlen)); 3072 end if; 3073 Next_Token; 3074 return; 3075 when others => 3076 Parse_Error ("declaration expected"); 3077 end case; 3078 Expect (Tok_Semicolon); 3079 Next_Token; 3080 end Parse_Declaration; 3081 3082-- procedure Put (Str : String) 3083-- is 3084-- L : Integer; 3085-- begin 3086-- L := Write (Standout, Str'Address, Str'Length); 3087-- end Put; 3088 3089 function Parse (Filename : String_Acc) return Boolean is 3090 begin 3091 -- Create the symbol hash table. 3092 Symtable := new Syment_Acc_Map (Hash_Primes (Cur_Prime_Idx)); 3093 3094 -- Initialize symbol table. 3095 Add_Keyword ("type", Tok_Type); 3096 Add_Keyword ("return", Tok_Return); 3097 Add_Keyword ("if", Tok_If); 3098 Add_Keyword ("then", Tok_Then); 3099 Add_Keyword ("else", Tok_Else); 3100 Add_Keyword ("elsif", Tok_Elsif); 3101 Add_Keyword ("loop", Tok_Loop); 3102 Add_Keyword ("exit", Tok_Exit); 3103 Add_Keyword ("next", Tok_Next); 3104 Add_Keyword ("signed", Tok_Signed); 3105 Add_Keyword ("unsigned", Tok_Unsigned); 3106 Add_Keyword ("float", Tok_Float); 3107 Add_Keyword ("is", Tok_Is); 3108 Add_Keyword ("of", Tok_Of); 3109 Add_Keyword ("all", Tok_All); 3110 Add_Keyword ("not", Tok_Not); 3111 Add_Keyword ("abs", Tok_Abs); 3112 Add_Keyword ("or", Tok_Or); 3113 Add_Keyword ("and", Tok_And); 3114 Add_Keyword ("xor", Tok_Xor); 3115 Add_Keyword ("mod", Tok_Mod); 3116 Add_Keyword ("rem", Tok_Rem); 3117 Add_Keyword ("array", Tok_Array); 3118 Add_Keyword ("access", Tok_Access); 3119 Add_Keyword ("record", Tok_Record); 3120 Add_Keyword ("subrecord", Tok_Subrecord); 3121 Add_Keyword ("union", Tok_Union); 3122 Add_Keyword ("end", Tok_End); 3123 Add_Keyword ("boolean", Tok_Boolean); 3124 Add_Keyword ("enum", Tok_Enum); 3125 Add_Keyword ("external", Tok_External); 3126 Add_Keyword ("private", Tok_Private); 3127 Add_Keyword ("public", Tok_Public); 3128 Add_Keyword ("local", Tok_Local); 3129 Add_Keyword ("procedure", Tok_Procedure); 3130 Add_Keyword ("function", Tok_Function); 3131 Add_Keyword ("constant", Tok_Constant); 3132 Add_Keyword ("var", Tok_Var); 3133 Add_Keyword ("subarray", Tok_Subarray); 3134 Add_Keyword ("declare", Tok_Declare); 3135 Add_Keyword ("begin", Tok_Begin); 3136 Add_Keyword ("end", Tok_End); 3137 Add_Keyword ("null", Tok_Null); 3138 Add_Keyword ("case", Tok_Case); 3139 Add_Keyword ("when", Tok_When); 3140 Add_Keyword ("default", Tok_Default); 3141 3142 Id_Address := New_Symbol ("address"); 3143 Id_Unchecked_Address := New_Symbol ("unchecked_address"); 3144 Id_Subprg_Addr := New_Symbol ("subprg_addr"); 3145 Id_Conv := New_Symbol ("conv"); 3146 Id_Sizeof := New_Symbol ("sizeof"); 3147 Id_Record_Sizeof := New_Symbol ("record_sizeof"); 3148 Id_Alignof := New_Symbol ("alignof"); 3149 Id_Alloca := New_Symbol ("alloca"); 3150 Id_Offsetof := New_Symbol ("offsetof"); 3151 3152 -- Initialize the scanner. 3153 Buf (1) := NUL; 3154 Pos := 1; 3155 Lineno := 1; 3156 if Filename = null then 3157 Fd := Standin; 3158 File_Name := new String'("*stdin*"); 3159 else 3160 declare 3161 Name : String (1 .. Filename'Length + 1); 3162 begin 3163 Name (1 .. Filename'Length) := Filename.all; 3164 Name (Name'Last) := NUL; 3165 File_Name := Filename; 3166 Fd := Open_Read (Name'Address, Text); 3167 if Fd = Invalid_FD then 3168 Puterr ("cannot open '" & Filename.all & '''); 3169 Newline_Err; 3170 return False; 3171 end if; 3172 end; 3173 end if; 3174 3175 New_Debug_Filename_Decl (File_Name.all); 3176 3177 Push_Scope; 3178 Next_Token; 3179 while Tok /= Tok_Eof loop 3180 Parse_Declaration; 3181 end loop; 3182 Pop_Scope; 3183 3184 if Fd /= Standin then 3185 Close (Fd); 3186 end if; 3187 return True; 3188 exception 3189 when Error => 3190 return False; 3191 when E : others => 3192 Puterr (Ada.Exceptions.Exception_Information (E)); 3193 raise; 3194 end Parse; 3195end Ortho_Front; 3196