From bddf80741a2a4f574e9b531c046a531d0d53ea86 Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Sat, 4 May 2019 22:04:37 +0200 Subject: vhdl: move parse package as vhdl child. --- src/ghdldrv/ghdlprint.adb | 4 +- src/vhdl/parse.adb | 9872 ---------------------------------- src/vhdl/parse.ads | 63 - src/vhdl/parse_psl.adb | 867 --- src/vhdl/parse_psl.ads | 30 - src/vhdl/sem_assocs.adb | 4 +- src/vhdl/sem_lib.adb | 6 +- src/vhdl/simulate/simul-debugger.adb | 7 +- src/vhdl/vhdl-parse.adb | 9871 +++++++++++++++++++++++++++++++++ src/vhdl/vhdl-parse.ads | 63 + src/vhdl/vhdl-parse_psl.adb | 867 +++ src/vhdl/vhdl-parse_psl.ads | 30 + 12 files changed, 10842 insertions(+), 10842 deletions(-) delete mode 100644 src/vhdl/parse.adb delete mode 100644 src/vhdl/parse.ads delete mode 100644 src/vhdl/parse_psl.adb delete mode 100644 src/vhdl/parse_psl.ads create mode 100644 src/vhdl/vhdl-parse.adb create mode 100644 src/vhdl/vhdl-parse.ads create mode 100644 src/vhdl/vhdl-parse_psl.adb create mode 100644 src/vhdl/vhdl-parse_psl.ads (limited to 'src') diff --git a/src/ghdldrv/ghdlprint.adb b/src/ghdldrv/ghdlprint.adb index a9a9f2627..7156be9e9 100644 --- a/src/ghdldrv/ghdlprint.adb +++ b/src/ghdldrv/ghdlprint.adb @@ -29,7 +29,7 @@ with Errorout; use Errorout; with Iirs_Utils; use Iirs_Utils; with Vhdl.Tokens; with Vhdl.Scanner; -with Parse; +with Vhdl.Parse; with Canon; with Version; with Xrefs; @@ -984,7 +984,7 @@ package body Ghdlprint is Setup_Libraries (True); -- Keep parenthesis during parse. - Parse.Flag_Parse_Parenthesis := True; + Vhdl.Parse.Flag_Parse_Parenthesis := True; Canon.Canon_Flag_Concurrent_Stmts := False; Canon.Canon_Flag_Configurations := False; diff --git a/src/vhdl/parse.adb b/src/vhdl/parse.adb deleted file mode 100644 index a5875e5c5..000000000 --- a/src/vhdl/parse.adb +++ /dev/null @@ -1,9872 +0,0 @@ --- VHDL parser. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Iir_Chains; use Iir_Chains; -with Vhdl.Tokens; use Vhdl.Tokens; -with Vhdl.Scanner; use Vhdl.Scanner; -with Iirs_Utils; use Iirs_Utils; -with Errorout; use Errorout; -with Std_Names; use Std_Names; -with Flags; use Flags; -with Parse_Psl; -with Str_Table; -with Xrefs; -with Elocations; use Elocations; - --- Recursive descendant parser. --- Each subprogram (should) parse one production rules. --- Rules are written in a comment just before the subprogram. --- terminals are written in upper case. --- non-terminal are written in lower case. --- syntaxic category of a non-terminal are written in upper case. --- eg: next_statement ::= [ label : ] NEXT [ LOOP_label ] [ WHEN condition ] ; --- Or (|) must be aligned by the previous or, or with the '=' character. --- Indentation is 4. --- --- To document what is expected for input and what is left as an output --- concerning token stream, a precond and a postcond comment shoud be --- added before the above rules. --- a token (such as IF or ';') means the current token is this token. --- 'a token' means the current token was analysed. --- 'next token' means the current token is to be analysed. - - -package body Parse is - - -- current_token must be valid. - -- Leaves a token. - function Parse_Primary return Iir_Expression; - function Parse_Use_Clause return Iir_Use_Clause; - - function Parse_Association_List return Iir; - function Parse_Association_List_In_Parenthesis return Iir; - - function Parse_Sequential_Statements (Parent : Iir) return Iir; - function Parse_Configuration_Item return Iir; - function Parse_Block_Configuration return Iir_Block_Configuration; - procedure Parse_Concurrent_Statements (Parent : Iir); - function Parse_Subprogram_Declaration return Iir; - function Parse_Subtype_Indication (Name : Iir := Null_Iir) return Iir; - function Parse_Interface_List (Ctxt : Interface_Kind_Type; Parent : Iir) - return Iir; - procedure Parse_Component_Specification (Res : Iir); - function Parse_Binding_Indication return Iir_Binding_Indication; - function Parse_Aggregate return Iir; - function Parse_Signature return Iir_Signature; - procedure Parse_Declarative_Part (Parent : Iir); - function Parse_Tolerance_Aspect_Opt return Iir; - function Parse_Package (Parent : Iir) return Iir; - - -- Maximum number of nested parenthesis, before generating an error. - Max_Parenthesis_Depth : constant Natural := 1000; - - -- Current number of open parenthesis (in expressions). - Parenthesis_Depth : Natural := 0; - - -- Copy the current location into an iir. - procedure Set_Location (Node : Iir) is - begin - Set_Location (Node, Get_Token_Location); - end Set_Location; - - -- Disp a message during parse - -- The location of the current token is automatically displayed before - -- the message. - procedure Error_Msg_Parse (Msg: String; Arg1 : Earg_Type) is - begin - Report_Msg (Msgid_Error, Errorout.Parse, No_Location, Msg, (1 => Arg1)); - end Error_Msg_Parse; - - procedure Error_Msg_Parse - (Msg: String; Args : Earg_Arr := No_Eargs; Cont : Boolean := False) is - begin - Report_Msg (Msgid_Error, Errorout.Parse, No_Location, Msg, Args, Cont); - end Error_Msg_Parse; - - procedure Error_Msg_Parse (Loc : Location_Type; - Msg: String; - Args : Earg_Arr := No_Eargs; - Cont : Boolean := False) is - begin - Report_Msg (Msgid_Error, Errorout.Parse, Loc, Msg, Args, Cont); - end Error_Msg_Parse; - - procedure Unexpected (Where: String) is - begin - Error_Msg_Parse ("unexpected token %t in a " & Where, +Current_Token); - end Unexpected; - - procedure Expect_Error (Token: Token_Type; Msg: String) - is - Loc : Location_Type; - begin - case Token is - when Tok_Semi_Colon - | Tok_Right_Paren - | Tok_Comma => - Loc := Get_Prev_Location; - when others => - Loc := Get_Token_Location; - end case; - - if Msg'Length > 0 then - Error_Msg_Parse (Loc, Msg, Args => No_Eargs, Cont => True); - Error_Msg_Parse (Loc, "(found: %t)", (1 => +Current_Token)); - elsif Current_Token = Tok_Identifier then - Error_Msg_Parse - (Loc, "%t is expected instead of %i", - (+Token, +Current_Identifier)); - else - Error_Msg_Parse - (Loc, "%t is expected instead of %t", (+Token, + Current_Token)); - end if; - end Expect_Error; - - -- Emit an error if the current_token if different from TOKEN. - -- Otherwise, accept the current_token (ie set it to tok_invalid, unless - -- TOKEN is Tok_Identifier). - procedure Expect (Token: Token_Type; Msg: String := "") is - begin - if Current_Token /= Token then - Expect_Error (Token, Msg); - end if; - end Expect; - - procedure Expect_Scan (Token: Token_Type; Msg: String := "") is - begin - if Current_Token = Token then - -- Skip token. - Scan; - else - Expect_Error (Token, Msg); - end if; - end Expect_Scan; - - -- Expect the identifier for node RES. - procedure Scan_Identifier (Res : Iir) is - begin - Set_Location (Res); - if Current_Token = Tok_Identifier then - Set_Identifier (Res, Current_Identifier); - - -- Skip identifier. - Scan; - else - Expect (Tok_Identifier); - end if; - end Scan_Identifier; - - -- If the current_token is an identifier, it must be equal to name. - -- In this case, a token is eaten. - -- If the current_token is not an identifier, this is a noop. - procedure Check_End_Name (Name : Name_Id; Decl : Iir) is - begin - if Current_Token /= Tok_Identifier then - return; - end if; - if Name = Null_Identifier then - Error_Msg_Parse - ("end label for an unlabeled declaration or statement"); - else - if Current_Identifier /= Name then - Error_Msg_Parse ("misspelling, %i expected", +Name); - else - Set_End_Has_Identifier (Decl, True); - Xrefs.Xref_End (Get_Token_Location, Decl); - end if; - end if; - - -- Skip identifier. - Scan; - end Check_End_Name; - - procedure Check_End_Name (Decl : Iir) is - begin - Check_End_Name (Get_Identifier (Decl), Decl); - end Check_End_Name; - - - -- Expect ' END tok [ name ] ; ' - procedure Check_End_Name (Tok : Token_Type; Decl : Iir) is - begin - if Current_Token /= Tok_End then - Error_Msg_Parse ("""end " & Image (Tok) & ";"" expected"); - else - Scan; - if Current_Token /= Tok then - Error_Msg_Parse ("""end"" must be followed by %t", +Tok); - else - Set_End_Has_Reserved_Id (Decl, True); - Scan; - end if; - Check_End_Name (Decl); - end if; - end Check_End_Name; - - procedure Skip_Until_Semi_Colon is - begin - loop - case Current_Token is - when Tok_Semi_Colon - | Tok_Eof => - exit; - when others => - Scan; - end case; - end loop; - end Skip_Until_Semi_Colon; - - procedure Resync_To_End_Of_Statement is - begin - loop - case Current_Token is - when Tok_Eof - | Tok_Semi_Colon - | Tok_End => - exit; - when Tok_If - | Tok_For - | Tok_While - | Tok_Loop - | Tok_Wait - | Tok_Assert => - -- Sequential statement. - exit; - when Tok_Process - | Tok_Block => - -- Concurrent statement. - exit; - when others => - Scan; - end case; - end loop; - end Resync_To_End_Of_Statement; - - procedure Resync_To_End_Of_Declaration is - begin - loop - case Current_Token is - when Tok_Eof => - exit; - when Tok_Semi_Colon => - Scan; - exit; - when Tok_End - | Tok_Begin => - -- End of current block. - exit; - when Tok_Signal - | Tok_Variable - | Tok_Constant - | Tok_File - | Tok_Alias - | Tok_Type - | Tok_Subtype - | Tok_Use - | Tok_Component - | Tok_Attribute - | Tok_Group - | Tok_For - | Tok_Disconnect - | Tok_Shared - | Tok_Impure - | Tok_Pure - | Tok_Function - | Tok_Procedure - | Tok_Package => - -- Start of a new declaration - exit; - when others => - -- Eat. - Scan; - end case; - end loop; - end Resync_To_End_Of_Declaration; - - procedure Resync_To_Next_Unit is - begin - -- Resync. - loop - case Current_Token is - when Tok_Eof => - exit; - when Tok_Semi_Colon => - -- Skip ';'. - Scan; - exit; - when Tok_Library - | Tok_Use - | Tok_Architecture - | Tok_Entity - | Tok_Package - | Tok_Configuration - | Tok_Context => - -- Possible start of a new unit. - exit; - when others => - Scan; - end case; - end loop; - end Resync_To_Next_Unit; - - procedure Skip_Until_Closing_Parenthesis - is - Level : Natural; - begin - Level := 0; - - -- Skip '('. - Scan; - - loop - case Current_Token is - when Tok_Right_Paren => - if Level = 0 then - -- Skip ')'. - Scan; - exit; - end if; - Level := Level - 1; - when Tok_Left_Paren => - Level := Level + 1; - when Tok_Eof - | Tok_Semi_Colon - | Tok_End - | Tok_Then - | Tok_Else - | Tok_Loop => - exit; - when others => - null; - end case; - - Scan; - end loop; - end Skip_Until_Closing_Parenthesis; - - -- Return True if at the end of the list, False if there is another - -- interface. - function Resync_To_End_Of_Interface return Boolean - is - Nested : Natural; - begin - Nested := 0; - loop - case Current_Token is - when Tok_End - | Tok_Port - | Tok_Is - | Tok_Begin - | Tok_Eof => - -- Certainly comes after interface list. - return True; - when Tok_Left_Paren => - Nested := Nested + 1; - when Tok_Right_Paren => - if Nested = 0 then - -- Skip ')'. - Scan; - - return True; - end if; - Nested := Nested - 1; - when Tok_Semi_Colon => - if Nested = 0 then - -- Skip ';'. - Scan; - - return False; - end if; - when Tok_Signal - | Tok_Variable - | Tok_Constant - | Tok_File - | Tok_Function - | Tok_Procedure - | Tok_Type - | Tok_Package => - -- Next interface ? - return False; - when Tok_Colon - | Tok_Identifier - | Tok_In - | Tok_Out - | Tok_Inout - | Tok_Buffer - | Tok_Linkage => - -- Certainly part of an interface. - null; - when others => - null; - end case; - - -- Skip token. - Scan; - end loop; - end Resync_To_End_Of_Interface; - - procedure Error_Missing_Semi_Colon (Msg : String) is - begin - Error_Msg_Parse (Get_Prev_Location, "missing "";"" at end of " & Msg); - end Error_Missing_Semi_Colon; - - -- Expect and scan ';' emit an error message using MSG if not present. - procedure Scan_Semi_Colon (Msg : String) is - begin - if Current_Token /= Tok_Semi_Colon then - Error_Missing_Semi_Colon (Msg); - else - Scan; - end if; - end Scan_Semi_Colon; - - procedure Scan_Semi_Colon_Declaration (Msg : String) is - begin - if Current_Token = Tok_Semi_Colon then - -- Skip ';'. - Scan; - else - Error_Missing_Semi_Colon (Msg); - - Resync_To_End_Of_Declaration; - end if; - end Scan_Semi_Colon_Declaration; - - procedure Scan_Semi_Colon_Unit (Msg : String) is - begin - if Current_Token = Tok_Semi_Colon then - -- Skip ';'. - Scan; - else - Error_Missing_Semi_Colon (Msg); - Resync_To_Next_Unit; - end if; - end Scan_Semi_Colon_Unit; - - function Create_Error_Node (Orig : Iir := Null_Iir) return Iir - is - Res : Iir; - begin - Res := Create_Error (Orig); - if Orig = Null_Iir then - Set_Location (Res); - end if; - return Res; - end Create_Error_Node; - - -- precond : next token - -- postcond: next token. - -- - -- [ LRM93 4.3.2 ] - -- mode ::= IN | OUT | INOUT | BUFFER | LINKAGE - -- - -- If there is no mode, DEFAULT is returned. - function Parse_Mode return Iir_Mode is - begin - case Current_Token is - when Tok_In => - Scan; - if Current_Token = Tok_Out then - -- Nice message for Ada users... - Error_Msg_Parse - ("typo error, 'in out' must be 'inout' in vhdl"); - Scan; - return Iir_Inout_Mode; - end if; - return Iir_In_Mode; - when Tok_Out => - Scan; - return Iir_Out_Mode; - when Tok_Inout => - Scan; - return Iir_Inout_Mode; - when Tok_Linkage => - Scan; - return Iir_Linkage_Mode; - when Tok_Buffer => - Scan; - return Iir_Buffer_Mode; - when others => - -- Cannot happen. - raise Internal_Error; - end case; - end Parse_Mode; - - -- precond : next token - -- postcond: next token - -- - -- [ LRM93 4.3.1.2 ] - -- signal_kind ::= REGISTER | BUS - -- - -- If there is no signal_kind, then no_signal_kind is returned. - procedure Parse_Signal_Kind - (Is_Guarded : out Boolean; Signal_Kind : out Iir_Signal_Kind) is - begin - if Current_Token = Tok_Bus then - -- Eat 'bus' - Scan; - - Is_Guarded := True; - Signal_Kind := Iir_Bus_Kind; - elsif Current_Token = Tok_Register then - -- Eat 'register' - Scan; - - Is_Guarded := True; - Signal_Kind := Iir_Register_Kind; - else - Is_Guarded := False; - -- Avoid uninitialized variable. - Signal_Kind := Iir_Bus_Kind; - end if; - end Parse_Signal_Kind; - - -- precond : TO, DOWNTO - -- postcond: next token - -- - -- Parse a range. - -- If LEFT is not null_iir, then it must be an expression corresponding to - -- the left limit of the range, and the current_token must be either - -- tok_to or tok_downto. - -- If left is null_iir, the current token is used to create the left limit - -- expression. - -- - -- [ LRM93 3.1 ] - -- range_constraint ::= RANGE range - -- - -- [ LRM93 3.1 ] - -- range ::= RANGE_attribute_name - -- | simple_expression direction simple_expression - -- - -- direction ::= TO | DOWNTO - function Parse_Range_Expression (Left : Iir) return Iir - is - Res : Iir; - begin - Res := Create_Iir (Iir_Kind_Range_Expression); - - if Left /= Null_Iir then - Set_Left_Limit_Expr (Res, Left); - Location_Copy (Res, Left); - end if; - - case Current_Token is - when Tok_To => - Set_Direction (Res, Iir_To); - when Tok_Downto => - Set_Direction (Res, Iir_Downto); - when others => - raise Internal_Error; - end case; - - -- Skip 'to' or 'downto'. - Scan; - - Set_Right_Limit_Expr (Res, Parse_Expression (Prio_Simple)); - return Res; - end Parse_Range_Expression; - - -- precond: next token - -- postcond: next token - function Parse_Range return Iir - is - Left: Iir; - begin - Left := Parse_Expression (Prio_Simple); - - case Current_Token is - when Tok_To - | Tok_Downto => - return Parse_Range_Expression (Left); - when others => - if Left /= Null_Iir then - if Is_Range_Attribute_Name (Left) then - return Left; - end if; - Error_Msg_Parse ("'to' or 'downto' expected"); - end if; - return Create_Error_Node (Left); - end case; - end Parse_Range; - - -- precond: next token (after RANGE) - -- postcond: next token - function Parse_Range_Constraint return Iir is - begin - if Current_Token = Tok_Box then - Error_Msg_Parse ("range constraint required"); - Scan; - return Null_Iir; - end if; - - return Parse_Range; - end Parse_Range_Constraint; - - -- precond: next token (after RANGE) - -- postcond: next token - function Parse_Range_Constraint_Of_Subtype_Indication - (Type_Mark : Iir; - Resolution_Indication : Iir := Null_Iir) - return Iir - is - Def : Iir; - begin - Def := Create_Iir (Iir_Kind_Subtype_Definition); - if Type_Mark /= Null_Iir then - Location_Copy (Def, Type_Mark); - Set_Subtype_Type_Mark (Def, Type_Mark); - else - Set_Location (Def); - end if; - Set_Range_Constraint (Def, Parse_Range_Constraint); - Set_Resolution_Indication (Def, Resolution_Indication); - Set_Tolerance (Def, Parse_Tolerance_Aspect_Opt); - - return Def; - end Parse_Range_Constraint_Of_Subtype_Indication; - - -- precond: next token - -- postcond: next token - -- - -- [ LRM93 3.2.1 ] - -- discrete_range ::= discrete_subtype_indication | range - function Parse_Discrete_Range return Iir - is - Left: Iir; - begin - Left := Parse_Expression (Prio_Simple); - - case Current_Token is - when Tok_To - | Tok_Downto => - return Parse_Range_Expression (Left); - when Tok_Range => - return Parse_Subtype_Indication (Left); - when others => - -- Either a /range/_attribute_name or a type_mark. - return Left; - end case; - end Parse_Discrete_Range; - - -- Convert the STR (0 .. LEN - 1) into a operator symbol identifier. - -- Emit an error message if the name is not an operator name. - function Str_To_Operator_Name (Str_Id : String8_Id; - Len : Nat32; - Loc : Location_Type) return Name_Id - is - -- LRM93 2.1 - -- Extra spaces are not allowed in an operator symbol, and the - -- case of letters is not signifiant. - - -- LRM93 2.1 - -- The sequence of characters represented by an operator symbol - -- must be an operator belonging to one of classes of operators - -- defined in section 7.2. - - procedure Bad_Operator_Symbol is - begin - Error_Msg_Parse - (+Loc, "%s is not an operator symbol", (1 => +((Str_Id, Len)))); - end Bad_Operator_Symbol; - - procedure Check_Vhdl93 is - begin - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse - (+Loc, "%s is not a vhdl87 operator symbol", - (1 => +((Str_Id, Len)))); - end if; - end Check_Vhdl93; - - Id : Name_Id; - C1, C2, C3, C4 : Character; - begin - C1 := Str_Table.Char_String8 (Str_Id, 1); - case Len is - when 1 => - -- =, <, >, +, -, *, /, & - case C1 is - when '=' => - Id := Name_Op_Equality; - when '>' => - Id := Name_Op_Greater; - when '<' => - Id := Name_Op_Less; - when '+' => - Id := Name_Op_Plus; - when '-' => - Id := Name_Op_Minus; - when '*' => - Id := Name_Op_Mul; - when '/' => - Id := Name_Op_Div; - when '&' => - Id := Name_Op_Concatenation; - when others => - Bad_Operator_Symbol; - Id := Name_Op_Plus; - end case; - when 2 => - -- or, /=, <=, >=, ** - C2 := Str_Table.Char_String8 (Str_Id, 2); - case C1 is - when 'o' | 'O' => - Id := Name_Or; - if C2 /= 'r' and C2 /= 'R' then - Bad_Operator_Symbol; - end if; - when '/' => - Id := Name_Op_Inequality; - if C2 /= '=' then - Bad_Operator_Symbol; - end if; - when '<' => - Id := Name_Op_Less_Equal; - if C2 /= '=' then - Bad_Operator_Symbol; - end if; - when '>' => - Id := Name_Op_Greater_Equal; - if C2 /= '=' then - Bad_Operator_Symbol; - end if; - when '*' => - Id := Name_Op_Exp; - if C2 /= '*' then - Bad_Operator_Symbol; - end if; - when '?' => - if Vhdl_Std < Vhdl_08 then - Bad_Operator_Symbol; - Id := Name_Op_Condition; - elsif C2 = '?' then - Id := Name_Op_Condition; - elsif C2 = '=' then - Id := Name_Op_Match_Equality; - elsif C2 = '<' then - Id := Name_Op_Match_Less; - elsif C2 = '>' then - Id := Name_Op_Match_Greater; - else - Bad_Operator_Symbol; - Id := Name_Op_Condition; - end if; - when others => - Bad_Operator_Symbol; - Id := Name_Op_Equality; - end case; - when 3 => - -- mod, rem, and, xor, nor, abs, not, sll, sla, sra, srl, rol - -- ror - C2 := Str_Table.Char_String8 (Str_Id, 2); - C3 := Str_Table.Char_String8 (Str_Id, 3); - case C1 is - when 'm' | 'M' => - Id := Name_Mod; - if (C2 /= 'o' and C2 /= 'O') or (C3 /= 'd' and C3 /= 'D') - then - Bad_Operator_Symbol; - end if; - when 'a' | 'A' => - if (C2 = 'n' or C2 = 'N') and (C3 = 'd' or C3 = 'D') then - Id := Name_And; - elsif (C2 = 'b' or C2 = 'B') and (C3 = 's' or C3 = 'S') then - Id := Name_Abs; - else - Id := Name_And; - Bad_Operator_Symbol; - end if; - when 'x' | 'X' => - Id := Name_Xor; - if (C2 /= 'o' and C2 /= 'O') or (C3 /= 'r' and C3 /= 'R') - then - Bad_Operator_Symbol; - end if; - when 'n' | 'N' => - if C2 = 'o' or C2 = 'O' then - if C3 = 'r' or C3 = 'R' then - Id := Name_Nor; - elsif C3 = 't' or C3 = 'T' then - Id := Name_Not; - else - Id := Name_Not; - Bad_Operator_Symbol; - end if; - else - Id := Name_Not; - Bad_Operator_Symbol; - end if; - when 's' | 'S' => - if C2 = 'l' or C2 = 'L' then - if C3 = 'l' or C3 = 'L' then - Check_Vhdl93; - Id := Name_Sll; - elsif C3 = 'a' or C3 = 'A' then - Check_Vhdl93; - Id := Name_Sla; - else - Id := Name_Sll; - Bad_Operator_Symbol; - end if; - elsif C2 = 'r' or C2 = 'R' then - if C3 = 'l' or C3 = 'L' then - Check_Vhdl93; - Id := Name_Srl; - elsif C3 = 'a' or C3 = 'A' then - Check_Vhdl93; - Id := Name_Sra; - else - Id := Name_Srl; - Bad_Operator_Symbol; - end if; - else - Id := Name_Sll; - Bad_Operator_Symbol; - end if; - when 'r' | 'R' => - if C2 = 'e' or C2 = 'E' then - if C3 = 'm' or C3 = 'M' then - Id := Name_Rem; - else - Id := Name_Rem; - Bad_Operator_Symbol; - end if; - elsif C2 = 'o' or C2 = 'O' then - if C3 = 'l' or C3 = 'L' then - Check_Vhdl93; - Id := Name_Rol; - elsif C3 = 'r' or C3 = 'R' then - Check_Vhdl93; - Id := Name_Ror; - else - Id := Name_Rol; - Bad_Operator_Symbol; - end if; - else - Id := Name_Rem; - Bad_Operator_Symbol; - end if; - when '?' => - if Vhdl_Std < Vhdl_08 then - Bad_Operator_Symbol; - Id := Name_Op_Match_Less_Equal; - else - if C2 = '<' and C3 = '=' then - Id := Name_Op_Match_Less_Equal; - elsif C2 = '>' and C3 = '=' then - Id := Name_Op_Match_Greater_Equal; - elsif C2 = '/' and C3 = '=' then - Id := Name_Op_Match_Inequality; - else - Bad_Operator_Symbol; - Id := Name_Op_Match_Less_Equal; - end if; - end if; - when others => - Id := Name_And; - Bad_Operator_Symbol; - end case; - when 4 => - -- nand, xnor - C2 := Str_Table.Char_String8 (Str_Id, 2); - C3 := Str_Table.Char_String8 (Str_Id, 3); - C4 := Str_Table.Char_String8 (Str_Id, 4); - if (C1 = 'n' or C1 = 'N') - and (C2 = 'a' or C2 = 'A') - and (C3 = 'n' or C3 = 'N') - and (C4 = 'd' or C4 = 'D') - then - Id := Name_Nand; - elsif (C1 = 'x' or C1 = 'X') - and (C2 = 'n' or C2 = 'N') - and (C3 = 'o' or C3 = 'O') - and (C4 = 'r' or C4 = 'R') - then - Check_Vhdl93; - Id := Name_Xnor; - else - Id := Name_Nand; - Bad_Operator_Symbol; - end if; - when others => - Id := Name_Op_Plus; - Bad_Operator_Symbol; - end case; - return Id; - end Str_To_Operator_Name; - - function Scan_To_Operator_Name (Loc : Location_Type) return Name_Id is - begin - return Str_To_Operator_Name - (Current_String_Id, Current_String_Length, Loc); - end Scan_To_Operator_Name; - pragma Inline (Scan_To_Operator_Name); - - -- Convert string literal STR to an operator symbol. - -- Emit an error message if the string is not an operator name. - function String_To_Operator_Symbol (Str : Iir) return Iir - is - Id : Name_Id; - Res : Iir; - begin - Id := Str_To_Operator_Name - (Get_String8_Id (Str), Get_String_Length (Str), Get_Location (Str)); - Res := Create_Iir (Iir_Kind_Operator_Symbol); - Location_Copy (Res, Str); - Set_Identifier (Res, Id); - Free_Iir (Str); - return Res; - end String_To_Operator_Symbol; - - -- precond : next token - -- postcond: next token - -- - -- [ LRM93 6.1 ] - -- name ::= simple_name - -- | operator_symbol - -- | selected_name - -- | indexed_name - -- | slice_name - -- | attribute_name - -- - -- [ LRM93 6.2 ] - -- simple_name ::= identifier - -- - -- [ LRM93 6.5 ] - -- slice_name ::= prefix ( discrete_range ) - -- - -- [ LRM93 6.3 ] - -- selected_name ::= prefix . suffix - -- - -- [ LRM93 6.1 ] - -- prefix ::= name - -- | function_call - -- - -- [ LRM93 6.3 ] - -- suffix ::= simple_name - -- | character_literal - -- | operator_symbol - -- | ALL - -- - -- [ LRM93 3.2.1 ] - -- discrete_range ::= DISCRETE_subtype_indication | range - -- - -- [ LRM93 3.1 ] - -- range ::= RANGE_attribute_name - -- | simple_expression direction simple_expression - -- - -- [ LRM93 3.1 ] - -- direction ::= TO | DOWNTO - -- - -- [ LRM93 6.6 ] - -- attribute_name ::= - -- prefix [ signature ] ' attribute_designator [ ( expression ) ] - -- - -- [ LRM93 6.6 ] - -- attribute_designator ::= ATTRIBUTE_simple_name - -- - -- Note: in order to simplify the parsing, this function may return a - -- signature without attribute designator. Signatures may appear at 3 - -- places: - -- - in attribute name - -- - in alias declaration - -- - in entity designator - function Parse_Name_Suffix (Pfx : Iir; - Allow_Indexes: Boolean := True; - Allow_Signature : Boolean := False) - return Iir - is - Res: Iir; - Prefix: Iir; - begin - Res := Pfx; - loop - Prefix := Res; - - case Current_Token is - when Tok_Left_Bracket => - if Get_Kind (Prefix) = Iir_Kind_String_Literal8 then - Prefix := String_To_Operator_Symbol (Prefix); - end if; - - -- There is a signature. They are normally followed by an - -- attribute. - Res := Parse_Signature; - Set_Signature_Prefix (Res, Prefix); - - when Tok_Tick => - -- There is an attribute. - if Get_Kind (Prefix) = Iir_Kind_String_Literal8 then - Prefix := String_To_Operator_Symbol (Prefix); - end if; - - -- Skip '''. - Scan; - - if Current_Token = Tok_Left_Paren then - -- A qualified expression. - Res := Create_Iir (Iir_Kind_Qualified_Expression); - Set_Type_Mark (Res, Prefix); - Location_Copy (Res, Prefix); - Set_Expression (Res, Parse_Aggregate); - return Res; - elsif Current_Token /= Tok_Range - and then Current_Token /= Tok_Identifier - and then not (Vhdl_Std >= Vhdl_08 - and then Current_Token = Tok_Subtype) - then - Expect - (Tok_Identifier, "attribute identifier expected after '"); - return Create_Error_Node (Prefix); - end if; - Res := Create_Iir (Iir_Kind_Attribute_Name); - Set_Identifier (Res, Current_Identifier); - Set_Location (Res); - if Get_Kind (Prefix) = Iir_Kind_Signature then - Set_Attribute_Signature (Res, Prefix); - - -- Transfer the prefix from the signature to the attribute. - Set_Prefix (Res, Get_Signature_Prefix (Prefix)); - Set_Signature_Prefix (Prefix, Null_Iir); - else - Set_Prefix (Res, Prefix); - end if; - - -- accept the identifier. - Scan; - - when Tok_Left_Paren => - if not Allow_Indexes then - return Res; - end if; - - if Get_Kind (Prefix) = Iir_Kind_String_Literal8 then - Prefix := String_To_Operator_Symbol (Prefix); - end if; - - Res := Create_Iir (Iir_Kind_Parenthesis_Name); - Set_Location (Res); - Set_Prefix (Res, Prefix); - Set_Association_Chain - (Res, Parse_Association_List_In_Parenthesis); - - when Tok_Dot => - if Get_Kind (Prefix) = Iir_Kind_String_Literal8 then - Prefix := String_To_Operator_Symbol (Prefix); - end if; - - -- Skip '.'. - Scan; - - case Current_Token is - when Tok_All => - Res := Create_Iir (Iir_Kind_Selected_By_All_Name); - Set_Location (Res); - Set_Prefix (Res, Prefix); - - -- Skip 'all'. - Scan; - - when Tok_Identifier - | Tok_Character => - Res := Create_Iir (Iir_Kind_Selected_Name); - Set_Location (Res); - Set_Prefix (Res, Prefix); - Set_Identifier (Res, Current_Identifier); - - -- Skip identifier/character. - Scan; - - when Tok_String => - Res := Create_Iir (Iir_Kind_Selected_Name); - Set_Location (Res); - Set_Prefix (Res, Prefix); - Set_Identifier - (Res, Scan_To_Operator_Name (Get_Token_Location)); - - -- Skip string. - Scan; - - when others => - Error_Msg_Parse - ("identifier or ""all"" is expected after '.'"); - Res := Prefix; - end case; - - when others => - if not Allow_Signature - and then Get_Kind (Res) = Iir_Kind_Signature - then - -- Not as a name. - Error_Msg_Parse ("signature name not expected here"); - Prefix := Get_Signature_Prefix (Res); - Set_Signature_Prefix (Res, Null_Iir); - Free_Iir (Res); - Res := Prefix; - end if; - return Res; - end case; - end loop; - end Parse_Name_Suffix; - - -- Precond: next token - -- Postcond: next token - -- - -- LRM08 8.7 External names - -- - -- external_pathname ::= - -- package_pathname - -- | absolute_pathname - -- | relative_pathname - -- - -- package_pathname ::= - -- @ library_logical_name . package_simple_name . - -- { package_simple_name . } object_simple_name - -- - -- absolute_pathname ::= - -- . partial_pathname - -- - -- relative_pathname ::= - -- { ^ . } partial_pathname - -- - -- partial_pathname ::= { pathname_element . } object_simple_name - -- - -- pathname_element ::= - -- entity_simple_name - -- | component_instantiation_label - -- | block_label - -- | generate_statement_label [ ( static_expression ) ] - -- | package_simple_name - function Parse_External_Pathname return Iir - is - Res : Iir; - Last : Iir; - El : Iir; - begin - case Current_Token is - when Tok_Arobase => - Res := Create_Iir (Iir_Kind_Package_Pathname); - Set_Location (Res); - Last := Res; - - -- Skip '@'. - Scan; - - if Current_Token /= Tok_Identifier then - Error_Msg_Parse ("library name expected after '@'"); - else - Set_Identifier (Res, Current_Identifier); - - -- Skip identifier. - Scan; - end if; - - if Current_Token /= Tok_Dot then - Error_Msg_Parse ("'.' expected after library name"); - else - -- Skip '.'. - Scan; - end if; - - when Tok_Dot => - Res := Create_Iir (Iir_Kind_Absolute_Pathname); - Set_Location (Res); - Last := Res; - - -- Skip '.'. - Scan; - - when Tok_Caret => - Last := Null_Iir; - loop - El := Create_Iir (Iir_Kind_Relative_Pathname); - Set_Location (El); - - -- Skip '^'. - Scan; - - if Current_Token /= Tok_Dot then - Error_Msg_Parse ("'.' expected after '^'"); - else - -- Skip '.'. - Scan; - end if; - - if Last = Null_Iir then - Res := El; - else - Set_Pathname_Suffix (Last, El); - end if; - Last := El; - - exit when Current_Token /= Tok_Caret; - end loop; - - when Tok_Identifier => - Last := Null_Iir; - - when others => - Last := Null_Iir; - -- Error is handled just below. - end case; - - -- Parse pathname elements. - loop - if Current_Token /= Tok_Identifier then - Error_Msg_Parse ("pathname element expected"); - -- FIXME: resync. - return Res; - end if; - - El := Create_Iir (Iir_Kind_Pathname_Element); - Set_Location (El); - Set_Identifier (El, Current_Identifier); - if Last = Null_Iir then - Res := El; - else - Set_Pathname_Suffix (Last, El); - end if; - Last := El; - - -- Skip identifier. - Scan; - - exit when Current_Token /= Tok_Dot; - - -- Skip '.'. - Scan; - end loop; - - return Res; - end Parse_External_Pathname; - - -- Precond: '<<' - -- Postcond: next token - -- - -- LRM08 8.7 External names - -- external_name ::= - -- external_constant_name - -- | external_signal_name - -- | external_variable_name - -- - -- external_constant_name ::= - -- << CONSTANT external_pathname : subtype_indication >> - -- - -- external_signal_name ::= - -- << SIGNAL external_pathname : subtype_indication >> - -- - -- external_variable_name ::= - -- << VARIABLE external_pathname : subtype_indication >> - function Parse_External_Name return Iir - is - Loc : Location_Type; - Res : Iir; - Kind : Iir_Kind; - begin - Loc := Get_Token_Location; - - -- Skip '<<'. - Scan; - - case Current_Token is - when Tok_Constant => - Kind := Iir_Kind_External_Constant_Name; - -- Skip 'constant'. - Scan; - when Tok_Signal => - Kind := Iir_Kind_External_Signal_Name; - -- Skip 'signal'. - Scan; - when Tok_Variable => - Kind := Iir_Kind_External_Variable_Name; - -- Skip 'variable'. - Scan; - when others => - Error_Msg_Parse - ("constant, signal or variable expected after '<<'"); - Kind := Iir_Kind_External_Signal_Name; - end case; - - Res := Create_Iir (Kind); - Set_Location (Res, Loc); - - Set_External_Pathname (Res, Parse_External_Pathname); - - if Current_Token /= Tok_Colon then - Error_Msg_Parse ("':' expected after external pathname"); - else - -- Skip ':' - Scan; - end if; - - Set_Subtype_Indication (Res, Parse_Subtype_Indication); - - if Current_Token /= Tok_Double_Greater then - Error_Msg_Parse ("'>>' expected at end of external name"); - else - -- Skip '>>' - Scan; - end if; - - return Res; - end Parse_External_Name; - - -- Precond: next token (identifier, string or '<<') - -- Postcond: next token - -- - -- LRM08 8. Names - -- name ::= - -- simple_name - -- | operator_symbol - -- | character_literal -- FIXME: not handled. - -- | selected_name - -- | indexed_name - -- | slice_name - -- | attribute_name - -- | external_name - function Parse_Any_Name - (Allow_Indexes: Boolean; Allow_Signature : Boolean) return Iir - is - Res: Iir; - begin - case Current_Token is - when Tok_Identifier => - Res := Create_Iir (Iir_Kind_Simple_Name); - Set_Identifier (Res, Current_Identifier); - Set_Location (Res); - - -- Skip identifier - Scan; - - when Tok_String => - -- For operator symbol, such as: "+" (A, B). - Res := Create_Iir (Iir_Kind_String_Literal8); - Set_String8_Id (Res, Current_String_Id); - Set_String_Length (Res, Current_String_Length); - Set_Location (Res); - - -- Skip string - Scan; - when Tok_Double_Less => - if Vhdl_Std < Vhdl_08 then - Error_Msg_Parse ("external name not allowed before vhdl 08"); - end if; - Res := Parse_External_Name; - when others => - if Current_Token = Tok_Invalid then - Error_Msg_Parse ("name expected here"); - else - Error_Msg_Parse - ("name expected here, found %t", +Current_Token); - end if; - return Create_Error_Node; - end case; - - return Parse_Name_Suffix (Res, Allow_Indexes, Allow_Signature); - end Parse_Any_Name; - - function Parse_Name (Allow_Indexes: Boolean := True) return Iir is - begin - return Parse_Any_Name (Allow_Indexes, False); - end Parse_Name; - - function Parse_Signature_Name return Iir is - begin - return Parse_Any_Name (True, True); - end Parse_Signature_Name; - - -- Emit an error message if MARK doesn't have the form of a type mark. - procedure Check_Type_Mark (Mark : Iir) is - begin - case Get_Kind (Mark) is - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - null; - when Iir_Kind_Attribute_Name => - -- For O'Subtype. - null; - when others => - Error_Msg_Parse (+Mark, "type mark must be a name of a type"); - end case; - end Check_Type_Mark; - - -- precond : next token - -- postcond: next token - -- - -- [ 4.2 ] - -- type_mark ::= type_name - -- | subtype_name - function Parse_Type_Mark (Check_Paren : Boolean := False) return Iir - is - Res : Iir; - Old : Iir; - pragma Unreferenced (Old); - begin - Res := Parse_Name (Allow_Indexes => False); - - Check_Type_Mark (Res); - if Check_Paren and then Current_Token = Tok_Left_Paren then - Error_Msg_Parse ("index constraint not allowed here"); - Old := Parse_Name_Suffix (Res, True); - end if; - return Res; - end Parse_Type_Mark; - - -- precond : CONSTANT, SIGNAL, VARIABLE. FILE or identifier - -- postcond: next token (';' or ')') - -- - -- [ LRM93 4.3.2 ] [ LRM08 6.5.2 ] - -- interface_declaration ::= interface_constant_declaration - -- | interface_signal_declaration - -- | interface_variable_declaration - -- | interface_file_declaration - -- - -- - -- [ LRM93 3.2.2 ] - -- identifier_list ::= identifier { , identifier } - -- - -- [ LRM93 4.3.2 ] - -- interface_constant_declaration ::= - -- [ CONSTANT ] identifier_list : [ IN ] subtype_indication - -- [ := STATIC_expression ] - -- - -- [ LRM93 4.3.2 ] - -- interface_file_declaration ::= FILE identifier_list : subtype_indication - -- - -- [ LRM93 4.3.2 ] - -- interface_signal_declaration ::= - -- [ SIGNAL ] identifier_list : [ mode ] subtype_indication [ BUS ] - -- [ := STATIC_expression ] - -- - -- [ LRM93 4.3.2 ] - -- interface_variable_declaration ::= - -- [ VARIABLE ] identifier_list : [ mode ] subtype_indication - -- [ := STATIC_expression ] - -- - -- The default kind of interface declaration is DEFAULT. - function Parse_Interface_Object_Declaration (Ctxt : Interface_Kind_Type) - return Iir - is - Kind : Iir_Kind; - Last : Iir; - First : Iir; - Inter: Iir; - Is_Default : Boolean; - Interface_Mode: Iir_Mode; - Interface_Type: Iir; - Is_Guarded : Boolean; - Signal_Kind: Iir_Signal_Kind; - Default_Value: Iir; - Has_Mode : Boolean; - Has_Class : Boolean; - begin - -- LRM08 6.5.2 Interface object declarations - -- Interface obejcts include interface constants that appear as - -- generics of a design entity, a component, a block, a package or - -- a subprogram, or as constant parameter of subprograms; interface - -- signals that appear as ports of a design entity, component or - -- block, or as signal parameters of subprograms; interface variables - -- that appear as variable parameter subprograms; interface files - -- that appear as file parameters of subrograms. - case Current_Token is - when Tok_Identifier => - -- The class of the object is unknown. Select default - -- according to the above rule, assuming the mode is IN. If - -- the mode is not IN, Parse_Interface_Object_Declaration will - -- change the class. - case Ctxt is - when Generic_Interface_List - | Parameter_Interface_List => - Kind := Iir_Kind_Interface_Constant_Declaration; - when Port_Interface_List => - Kind := Iir_Kind_Interface_Signal_Declaration; - end case; - when Tok_Constant => - Kind := Iir_Kind_Interface_Constant_Declaration; - when Tok_Signal => - if Ctxt = Generic_Interface_List then - Error_Msg_Parse - ("signal interface not allowed in generic clause"); - end if; - Kind := Iir_Kind_Interface_Signal_Declaration; - when Tok_Variable => - if Ctxt not in Parameter_Interface_List then - Error_Msg_Parse - ("variable interface not allowed in generic or port clause"); - end if; - Kind := Iir_Kind_Interface_Variable_Declaration; - when Tok_File => - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse ("file interface not allowed in vhdl 87"); - end if; - if Ctxt not in Parameter_Interface_List then - Error_Msg_Parse - ("variable interface not allowed in generic or port clause"); - end if; - Kind := Iir_Kind_Interface_File_Declaration; - when others => - -- Fall back in case of parse error. - Kind := Iir_Kind_Interface_Variable_Declaration; - end case; - - First := Create_Iir (Kind); - - if Flag_Elocations then - Create_Elocations (First); - Set_Start_Location (First, Get_Token_Location); - end if; - - if Current_Token = Tok_Identifier then - Is_Default := True; - Has_Class := False; - else - Is_Default := False; - Has_Class := True; - - -- Skip 'signal', 'variable', 'constant' or 'file'. - Scan; - end if; - - -- Parse list of identifiers. - Inter := First; - Last := First; - loop - Scan_Identifier (Inter); - - exit when Current_Token /= Tok_Comma; - - -- Skip ',' - Scan; - - Inter := Create_Iir (Kind); - - if Flag_Elocations then - Create_Elocations (Inter); - Set_Start_Location (Inter, Get_Start_Location (First)); - end if; - - Set_Chain (Last, Inter); - Last := Inter; - end loop; - - if Flag_Elocations then - Set_Colon_Location (First, Get_Token_Location); - end if; - - -- Skip ':' - Expect_Scan (Tok_Colon, "':' expected after interface identifier"); - - -- Parse mode. - case Current_Token is - when Tok_In - | Tok_Out - | Tok_Inout - | Tok_Linkage - | Tok_Buffer => - Interface_Mode := Parse_Mode; - Has_Mode := True; - when others => - Interface_Mode := Iir_Unknown_Mode; - Has_Mode := False; - end case; - - -- LRM93 2.1.1 LRM08 4.2.2.1 - -- If the mode is INOUT or OUT, and no object class is explicitly - -- specified, variable is assumed. - if Is_Default - and then Ctxt in Parameter_Interface_List - and then Interface_Mode in Iir_Out_Modes - then - -- Convert into variable. - declare - O_Interface : Iir_Interface_Constant_Declaration; - N_Interface : Iir_Interface_Variable_Declaration; - begin - O_Interface := First; - while O_Interface /= Null_Iir loop - N_Interface := - Create_Iir (Iir_Kind_Interface_Variable_Declaration); - Location_Copy (N_Interface, O_Interface); - Set_Identifier (N_Interface, Get_Identifier (O_Interface)); - - if Flag_Elocations then - Create_Elocations (N_Interface); - Set_Start_Location - (N_Interface, Get_Start_Location (O_Interface)); - Set_Colon_Location - (N_Interface, Get_Colon_Location (O_Interface)); - end if; - - if O_Interface = First then - First := N_Interface; - else - Set_Chain (Last, N_Interface); - end if; - Last := N_Interface; - - Inter := Get_Chain (O_Interface); - if Flag_Elocations then - Delete_Elocations (O_Interface); - end if; - Free_Iir (O_Interface); - O_Interface := Inter; - end loop; - Inter := First; - end; - end if; - - -- Parse mode (and handle default mode). - case Iir_Kinds_Interface_Object_Declaration (Get_Kind (Inter)) is - when Iir_Kind_Interface_File_Declaration => - if Interface_Mode /= Iir_Unknown_Mode then - Error_Msg_Parse - ("mode can't be specified for a file interface"); - end if; - Interface_Mode := Iir_Inout_Mode; - when Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Interface_Variable_Declaration => - -- LRM93 4.3.2 - -- If no mode is explicitly given in an interface declaration - -- other than an interface file declaration, mode IN is - -- assumed. - if Interface_Mode = Iir_Unknown_Mode then - Interface_Mode := Iir_In_Mode; - end if; - when Iir_Kind_Interface_Constant_Declaration => - if Interface_Mode = Iir_Unknown_Mode then - Interface_Mode := Iir_In_Mode; - elsif Interface_Mode /= Iir_In_Mode then - Error_Msg_Parse ("mode must be 'in' for a constant"); - Interface_Mode := Iir_In_Mode; - end if; - end case; - - Interface_Type := Parse_Subtype_Indication; - - -- Signal kind (but only for signal). - if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then - Parse_Signal_Kind (Is_Guarded, Signal_Kind); - else - Is_Guarded := False; - Signal_Kind := Iir_Register_Kind; - end if; - - if Current_Token = Tok_Assign then - if Get_Kind (Inter) = Iir_Kind_Interface_File_Declaration then - Error_Msg_Parse - ("default expression not allowed for an interface file"); - end if; - - -- Skip ':=' - if Flag_Elocations then - Set_Assign_Location (First, Get_Token_Location); - end if; - Scan; - - Default_Value := Parse_Expression; - else - Default_Value := Null_Iir; - end if; - - -- Subtype_Indication and Default_Value are set only on the first - -- interface. - Set_Subtype_Indication (First, Interface_Type); - if Get_Kind (First) /= Iir_Kind_Interface_File_Declaration then - Set_Default_Value (First, Default_Value); - end if; - - Inter := First; - while Inter /= Null_Iir loop - Set_Mode (Inter, Interface_Mode); - Set_Is_Ref (Inter, Inter /= First); - Set_Has_Mode (Inter, Has_Mode); - Set_Has_Class (Inter, Has_Class); - Set_Has_Identifier_List (Inter, Inter /= Last); - if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then - Set_Guarded_Signal_Flag (Inter, Is_Guarded); - Set_Signal_Kind (Inter, Signal_Kind); - end if; - Inter := Get_Chain (Inter); - end loop; - - return First; - end Parse_Interface_Object_Declaration; - - -- Precond : 'package' - -- Postcond: next token - -- - -- LRM08 6.5.5 Interface package declarations - -- interface_package_declaration ::= - -- PACKAGE identifier IS NEW uninstantiated_package name - -- interface_package_generic_map_aspect - -- - -- interface_package_generic_map_aspect ::= - -- generic_map_aspect - -- | GENERIC MAP ( <> ) - -- | GENERIC MAP ( DEFAULT ) - function Parse_Interface_Package_Declaration return Iir - is - Inter : Iir; - Map : Iir; - begin - Inter := Create_Iir (Iir_Kind_Interface_Package_Declaration); - - -- Skip 'package'. - Scan; - - Scan_Identifier (Inter); - - -- Skip 'is'. - Expect_Scan (Tok_Is); - - -- Skip 'new'. - Expect_Scan (Tok_New); - - Set_Uninstantiated_Package_Name (Inter, Parse_Name (False)); - - -- Skip 'generic' - Expect_Scan (Tok_Generic); - - -- Skip 'map' - Expect_Scan (Tok_Map); - - -- Skip '(' - Expect_Scan (Tok_Left_Paren); - - case Current_Token is - when Tok_Box => - Map := Null_Iir; - -- Skip '<>' - Scan; - when others => - Map := Parse_Association_List; - end case; - Set_Generic_Map_Aspect_Chain (Inter, Map); - - -- Skip ')' - Expect_Scan (Tok_Right_Paren); - - return Inter; - end Parse_Interface_Package_Declaration; - - -- Precond: identifier or string - -- Postcond: next token - -- - -- [ 2.1 ] - -- designator ::= identifier | operator_symbol - procedure Parse_Subprogram_Designator (Subprg : Iir) is - begin - if Current_Token = Tok_Identifier then - -- Skip identifier. - Scan_Identifier (Subprg); - elsif Current_Token = Tok_String then - if Kind_In (Subprg, Iir_Kind_Procedure_Declaration, - Iir_Kind_Interface_Procedure_Declaration) - then - -- LRM93 2.1 - -- A procedure designator is always an identifier. - Error_Msg_Parse ("a procedure name must be an identifier"); - end if; - -- LRM93 2.1 - -- A function designator is either an identifier or an operator - -- symbol. - Set_Identifier (Subprg, Scan_To_Operator_Name (Get_Token_Location)); - Set_Location (Subprg); - - -- Skip string. - Scan; - else - -- Just to display a parse error. - Expect (Tok_Identifier); - end if; - end Parse_Subprogram_Designator; - - -- Precond: '(' or return or any - -- Postcond: next token - procedure Parse_Subprogram_Parameters_And_Return - (Subprg : Iir; Is_Func : Boolean) - is - Old : Iir; - pragma Unreferenced (Old); - Inters : Iir; - begin - if Current_Token = Tok_Parameter then - Set_Has_Parameter (Subprg, True); - - -- Eat 'parameter' - Scan; - - if Current_Token /= Tok_Left_Paren then - Error_Msg_Parse - ("'parameter' must be followed by a list of parameters"); - end if; - end if; - - if Current_Token = Tok_Left_Paren then - -- Parse the interface declaration. - if Is_Func then - Inters := Parse_Interface_List - (Function_Parameter_Interface_List, Subprg); - else - Inters := Parse_Interface_List - (Procedure_Parameter_Interface_List, Subprg); - end if; - Set_Interface_Declaration_Chain (Subprg, Inters); - end if; - - if Current_Token = Tok_Return then - if not Is_Func then - Error_Msg_Parse - ("'return' not allowed for a procedure", Cont => True); - Error_Msg_Parse - ("(remove return part or declare a function)"); - - -- Skip 'return' - Scan; - - Old := Parse_Type_Mark; - else - -- Skip 'return' - Scan; - - Set_Return_Type_Mark - (Subprg, Parse_Type_Mark (Check_Paren => True)); - end if; - else - if Is_Func then - Error_Msg_Parse ("'return' expected"); - Set_Return_Type_Mark (Subprg, Create_Error_Node); - end if; - end if; - end Parse_Subprogram_Parameters_And_Return; - - -- Precond: PROCEDURE, FUNCTION, PURE, IMPURE - -- Postcond: next token - -- - -- LRM08 6.5.4 Interface subrpogram declarations - -- interface_subprogram_declaration ::= - -- interface_subprogram_specification - -- [ IS interface_subprogram_default ] - -- - -- interface_subrpogram_specification ::= - -- interface_procedure_specification | interface_function_specification - -- - -- interface_procedure_specification ::= - -- PROCEDURE designator - -- [ [ PARAMETER ] ( formal_parameter_list ) ] - -- - -- interface_function_specification ::= - -- [ PURE | IMPURE ] FUNCTION designator - -- [ [ PARAMETER ] ( formal_parameter_list ) ] RETURN type_mark - -- - -- interface_subprogram_default ::= - -- /subprogram/_name | <> - function Parse_Interface_Subprogram_Declaration return Iir - is - Kind : Iir_Kind; - Subprg: Iir; - Old : Iir; - pragma Unreferenced (Old); - begin - -- Create the node. - case Current_Token is - when Tok_Procedure => - Kind := Iir_Kind_Interface_Procedure_Declaration; - when Tok_Function - | Tok_Pure - | Tok_Impure => - Kind := Iir_Kind_Interface_Function_Declaration; - when others => - raise Internal_Error; - end case; - Subprg := Create_Iir (Kind); - Set_Location (Subprg); - - case Current_Token is - when Tok_Procedure => - -- Skip 'procedure'. - Scan; - when Tok_Function => - -- LRM93 2.1 - -- A function is impure if its specification contains the - -- reserved word IMPURE; otherwise it is said to be pure. - Set_Pure_Flag (Subprg, True); - - -- Skip 'function'. - Scan; - when Tok_Pure - | Tok_Impure => - Set_Pure_Flag (Subprg, Current_Token = Tok_Pure); - Set_Has_Pure (Subprg, True); - - -- Eat 'pure' or 'impure'. - Scan; - - Expect_Scan - (Tok_Function, "'function' must follow 'pure' or 'impure'"); - when others => - raise Internal_Error; - end case; - - -- Designator. - Parse_Subprogram_Designator (Subprg); - - Parse_Subprogram_Parameters_And_Return - (Subprg, Kind = Iir_Kind_Interface_Function_Declaration); - - -- TODO: interface_subprogram_default - - return Subprg; - end Parse_Interface_Subprogram_Declaration; - - -- Precond : '(' - -- Postcond: next token - -- - -- LRM08 6.5.6 Interface lists - -- interface_list ::= interface_element { ';' interface_element } - -- - -- interface_element ::= interface_declaration - function Parse_Interface_List (Ctxt : Interface_Kind_Type; Parent : Iir) - return Iir - is - Res, Last : Iir; - Inters : Iir; - Next : Iir; - Prev_Loc : Location_Type; - begin - Prev_Loc := Get_Token_Location; - - -- Skip '('. - Expect_Scan (Tok_Left_Paren); - - Res := Null_Iir; - Last := Null_Iir; - loop - case Current_Token is - when Tok_Identifier - | Tok_Signal - | Tok_Variable - | Tok_Constant - | Tok_File => - -- An inteface object. - Inters := Parse_Interface_Object_Declaration (Ctxt); - when Tok_Package => - if Ctxt /= Generic_Interface_List then - Error_Msg_Parse - ("package interface only allowed in generic interface"); - elsif Flags.Vhdl_Std < Vhdl_08 then - Error_Msg_Parse - ("package interface not allowed before vhdl 08"); - end if; - Inters := Parse_Interface_Package_Declaration; - when Tok_Type => - if Ctxt /= Generic_Interface_List then - Error_Msg_Parse - ("type interface only allowed in generic interface"); - elsif Flags.Vhdl_Std < Vhdl_08 then - Error_Msg_Parse - ("type interface not allowed before vhdl 08"); - end if; - Inters := Create_Iir (Iir_Kind_Interface_Type_Declaration); - - -- Skip 'type'. - Scan; - - Scan_Identifier (Inters); - when Tok_Procedure - | Tok_Pure - | Tok_Impure - | Tok_Function => - if Ctxt /= Generic_Interface_List then - Error_Msg_Parse - ("subprogram interface only allowed in generic interface"); - elsif Flags.Vhdl_Std < Vhdl_08 then - Error_Msg_Parse - ("subprogram interface not allowed before vhdl 08"); - end if; - Inters := Parse_Interface_Subprogram_Declaration; - when Tok_Right_Paren => - if Res = Null_Iir then - Error_Msg_Parse - (Prev_Loc, "empty interface list not allowed"); - else - Error_Msg_Parse - (Prev_Loc, "extra ';' at end of interface list"); - end if; - - -- Skip ')'. - Scan; - - exit; - when others => - Error_Msg_Parse ("interface declaration expected"); - -- Use a variable interface as a fall-back. - Inters := Parse_Interface_Object_Declaration (Ctxt); - end case; - - -- Chain - if Last = Null_Iir then - Res := Inters; - else - Set_Chain (Last, Inters); - end if; - - -- Set parent and set Last to the last interface. - Last := Inters; - loop - Set_Parent (Last, Parent); - Next := Get_Chain (Last); - exit when Next = Null_Iir; - Last := Next; - end loop; - - Prev_Loc := Get_Token_Location; - - case Current_Token is - when Tok_Comma => - Error_Msg_Parse - ("interfaces must be separated by ';' (found ',')"); - - -- Skip ','. - Scan; - when Tok_Semi_Colon => - -- Skip ';'. - Scan; - when Tok_Right_Paren => - -- Skip ')'. - Scan; - - exit; - when others => - -- Try to resync; skip tokens until ';', ')'. Handled nested - -- parenthesis. - Error_Msg_Parse ("';' or ')' expected after interface"); - - if Resync_To_End_Of_Interface then - exit; - end if; - end case; - end loop; - - return Res; - end Parse_Interface_List; - - -- precond : PORT - -- postcond: next token - -- - -- [ LRM93 1.1.1 ] - -- port_clause ::= PORT ( port_list ) ; - -- - -- [ LRM93 1.1.1.2 ] - -- port_list ::= PORT_interface_list - procedure Parse_Port_Clause (Parent : Iir) - is - Res: Iir; - El : Iir; - begin - -- Skip 'port' - pragma Assert (Current_Token = Tok_Port); - Scan; - - Res := Parse_Interface_List (Port_Interface_List, Parent); - - -- Check the interface are signal interfaces. - El := Res; - while El /= Null_Iir loop - if Get_Kind (El) /= Iir_Kind_Interface_Signal_Declaration then - Error_Msg_Parse (+El, "port must be a signal"); - end if; - El := Get_Chain (El); - end loop; - - Scan_Semi_Colon ("port clause"); - Set_Port_Chain (Parent, Res); - end Parse_Port_Clause; - - -- precond : GENERIC - -- postcond: next token - -- - -- [ LRM93 1.1.1, LRM08 6.5.6.2 ] - -- generic_clause ::= GENERIC ( generic_list ) ; - -- - -- [ LRM93 1.1.1.1, LRM08 6.5.6.2] - -- generic_list ::= GENERIC_interface_list - procedure Parse_Generic_Clause (Parent : Iir) - is - Res: Iir; - begin - -- Skip 'generic' - pragma Assert (Current_Token = Tok_Generic); - Scan; - - Res := Parse_Interface_List (Generic_Interface_List, Parent); - Set_Generic_Chain (Parent, Res); - - Scan_Semi_Colon ("generic clause"); - end Parse_Generic_Clause; - - -- precond : a token. - -- postcond: next token - -- - -- [ LRM93 1.1.1 ] - -- entity_header ::= - -- [ FORMAL_generic_clause ] - -- [ FORMAL_port_clause ] - -- - -- [ LRM93 4.5 ] - -- [ LOCAL_generic_clause ] - -- [ LOCAL_port_clause ] - procedure Parse_Generic_Port_Clauses (Parent : Iir) - is - Has_Port, Has_Generic : Boolean; - begin - Has_Port := False; - Has_Generic := False; - loop - if Current_Token = Tok_Generic then - if Has_Generic then - Error_Msg_Parse ("at most one generic clause is allowed"); - end if; - if Has_Port then - Error_Msg_Parse ("generic clause must precede port clause"); - end if; - - if Flag_Elocations then - Set_Generic_Location (Parent, Get_Token_Location); - end if; - - Has_Generic := True; - Parse_Generic_Clause (Parent); - elsif Current_Token = Tok_Port then - if Has_Port then - Error_Msg_Parse ("at most one port clause is allowed"); - end if; - - if Flag_Elocations then - Set_Port_Location (Parent, Get_Token_Location); - end if; - - Has_Port := True; - Parse_Port_Clause (Parent); - else - exit; - end if; - end loop; - end Parse_Generic_Port_Clauses; - - -- precond : a token - -- postcond: next token - -- - -- [ LRM93 3.1.1 ] - -- enumeration_type_definition ::= - -- ( enumeration_literal { , enumeration_literal } ) - -- - -- [ LRM93 3.1.1 ] - -- enumeration_literal ::= identifier | character_literal - function Parse_Enumeration_Type_Definition (Parent : Iir) - return Iir_Enumeration_Type_Definition - is - Pos: Iir_Int32; - Enum_Lit: Iir_Enumeration_Literal; - Enum_Type: Iir_Enumeration_Type_Definition; - Enum_List : Iir_List; - begin - -- This is an enumeration. - Enum_Type := Create_Iir (Iir_Kind_Enumeration_Type_Definition); - Set_Location (Enum_Type); - Enum_List := Create_Iir_List; - - -- LRM93 3.1.1 - -- The position number of the first listed enumeration literal is zero. - Pos := 0; - - -- Eat '('. - Scan; - - if Current_Token = Tok_Right_Paren then - Error_Msg_Parse ("at least one literal must be declared"); - else - loop - if Current_Token = Tok_Identifier - or Current_Token = Tok_Character - then - Enum_Lit := Create_Iir (Iir_Kind_Enumeration_Literal); - Set_Identifier (Enum_Lit, Current_Identifier); - Set_Parent (Enum_Lit, Parent); - Set_Location (Enum_Lit); - Set_Enum_Pos (Enum_Lit, Pos); - - -- LRM93 3.1.1 - -- the position number for each additional enumeration literal - -- is one more than that if its predecessor in the list. - Pos := Pos + 1; - - Append_Element (Enum_List, Enum_Lit); - - -- Skip identifier or character. - Scan; - else - Error_Msg_Parse ("identifier or character expected"); - end if; - - exit when Current_Token /= Tok_Comma; - - -- Skip ','. - Scan; - - if Current_Token = Tok_Right_Paren then - Error_Msg_Parse ("extra ',' ignored"); - exit; - end if; - end loop; - end if; - - -- Skip ')'. - Expect_Scan (Tok_Right_Paren, "')' expected at end of enumeration type"); - - Set_Enumeration_Literal_List (Enum_Type, List_To_Flist (Enum_List)); - - return Enum_Type; - end Parse_Enumeration_Type_Definition; - - -- precond : ARRAY - -- postcond: ?? - -- - -- [ LRM93 3.2.1 ] - -- array_type_definition ::= unconstrained_array_definition - -- | constrained_array_definition - -- - -- unconstrained_array_definition ::= - -- ARRAY ( index_subtype_definition { , index_subtype_definition } ) - -- OF element_subtype_indication - -- - -- constrained_array_definition ::= - -- ARRAY index_constraint OF element_subtype_indication - -- - -- index_subtype_definition ::= type_mark RANGE <> - -- - -- index_constraint ::= ( discrete_range { , discrete_range } ) - -- - -- discrete_range ::= discrete_subtype_indication | range - -- - -- [ LRM08 5.3.2.1 ] - -- array_type_definition ::= unbounded_array_definition - -- | constrained_array_definition - -- - -- unbounded_array_definition ::= - -- ARRAY ( index_subtype_definition { , index_subtype_definition } ) - -- OF element_subtype_indication - function Parse_Array_Type_Definition return Iir - is - Index_Constrained : Boolean; - Array_Constrained : Boolean; - First : Boolean; - Res_Type: Iir; - Index_List : Iir_List; - - Loc : Location_Type; - Def : Iir; - Type_Mark : Iir; - Element_Subtype : Iir; - begin - Loc := Get_Token_Location; - - -- Skip 'array'. - Scan; - - -- Skip '('. - Expect_Scan (Tok_Left_Paren); - - First := True; - Index_List := Create_Iir_List; - - loop - -- The accepted syntax can be one of: - -- * index_subtype_definition, which is: - -- * type_mark RANGE <> - -- * discrete_range, which is either: - -- * /discrete/_subtype_indication - -- * [ resolution_indication ] type_mark [ range_constraint ] - -- * range_constraint ::= RANGE range - -- * range - -- * /range/_attribute_name - -- * simple_expression direction simple_expression - - -- Parse a simple expression (for the range), which can also parse a - -- name. - Type_Mark := Parse_Expression (Prio_Simple); - - case Current_Token is - when Tok_Range => - -- Skip 'range' - Scan; - - if Current_Token = Tok_Box then - -- Parsed 'RANGE <>': this is an index_subtype_definition. - Index_Constrained := False; - Scan; - Def := Type_Mark; - else - -- This is a /discrete/_subtype_indication - Index_Constrained := True; - Def := - Parse_Range_Constraint_Of_Subtype_Indication (Type_Mark); - end if; - when Tok_To - | Tok_Downto => - -- A range - Index_Constrained := True; - Def := Parse_Range_Expression (Type_Mark); - when others => - -- For a /range/_attribute_name - Index_Constrained := True; - Def := Type_Mark; - end case; - - if First then - Array_Constrained := Index_Constrained; - First := False; - else - if Array_Constrained /= Index_Constrained then - Error_Msg_Parse - ("cannot mix constrained and unconstrained index"); - Def := Create_Error_Node (Def); - end if; - end if; - - Append_Element (Index_List, Def); - - exit when Current_Token /= Tok_Comma; - - -- Skip ','. - Scan; - end loop; - - -- Skip ')' and 'of' - Expect_Scan (Tok_Right_Paren); - Expect_Scan (Tok_Of); - - Element_Subtype := Parse_Subtype_Indication; - - if Array_Constrained then - -- Sem_Type will create the array type. - Res_Type := Create_Iir (Iir_Kind_Array_Subtype_Definition); - Set_Array_Element_Constraint (Res_Type, Element_Subtype); - Set_Index_Constraint_List (Res_Type, List_To_Flist (Index_List)); - else - Res_Type := Create_Iir (Iir_Kind_Array_Type_Definition); - Set_Element_Subtype_Indication (Res_Type, Element_Subtype); - Set_Index_Subtype_Definition_List (Res_Type, - List_To_Flist (Index_List)); - end if; - Set_Location (Res_Type, Loc); - - return Res_Type; - end Parse_Array_Type_Definition; - - -- precond : UNITS - -- postcond: next token - -- - -- [ LRM93 3.1.3 ] - -- physical_type_definition ::= - -- range_constraint - -- UNITS - -- base_unit_declaration - -- { secondary_unit_declaration } - -- END UNITS [ PHYSICAL_TYPE_simple_name ] - -- - -- [ LRM93 3.1.3 ] - -- base_unit_declaration ::= identifier ; - -- - -- [ LRM93 3.1.3 ] - -- secondary_unit_declaration ::= identifier = physical_literal ; - function Parse_Physical_Type_Definition (Parent : Iir) - return Iir_Physical_Type_Definition - is - use Iir_Chains.Unit_Chain_Handling; - Res: Iir_Physical_Type_Definition; - Unit: Iir_Unit_Declaration; - Last : Iir_Unit_Declaration; - Multiplier : Iir; - begin - Res := Create_Iir (Iir_Kind_Physical_Type_Definition); - Set_Location (Res); - - -- Skip 'units' - Expect_Scan (Tok_Units); - - -- Parse primary unit. - Unit := Create_Iir (Iir_Kind_Unit_Declaration); - Set_Parent (Unit, Parent); - - Scan_Identifier (Unit); - - Scan_Semi_Colon ("primary physical unit"); - - Build_Init (Last); - Append (Last, Res, Unit); - - -- Parse secondary units. - while Current_Token = Tok_Identifier loop - Unit := Create_Iir (Iir_Kind_Unit_Declaration); - Set_Parent (Unit, Parent); - - Scan_Identifier (Unit); - - -- Skip '='. - Expect_Scan (Tok_Equal); - - case Current_Token is - when Tok_Integer - | Tok_Identifier - | Tok_Real => - Multiplier := Parse_Primary; - when others => - Error_Msg_Parse - ("physical literal expected to define a secondary unit"); - Skip_Until_Semi_Colon; - Multiplier := Null_Iir; - end case; - - if Multiplier /= Null_Iir then - Set_Physical_Literal (Unit, Multiplier); - - case Get_Kind (Multiplier) is - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name - | Iir_Kind_Physical_Int_Literal => - null; - when Iir_Kind_Physical_Fp_Literal => - Error_Msg_Parse - ("secondary units may only be defined by an integer"); - when others => - Error_Msg_Parse ("a physical literal is expected here"); - Skip_Until_Semi_Colon; - end case; - end if; - Append (Last, Res, Unit); - Scan_Semi_Colon ("secondary physical unit"); - end loop; - - -- Skip 'end'. - Expect_Scan (Tok_End); - - -- Skip 'units'. - Expect_Scan (Tok_Units); - Set_End_Has_Reserved_Id (Res, True); - - return Res; - end Parse_Physical_Type_Definition; - - -- precond : RECORD - -- postcond: next token - -- - -- [ LRM93 3.2.2 ] - -- record_type_definition ::= - -- RECORD - -- element_declaration - -- { element_declaration } - -- END RECORD [ RECORD_TYPE_simple_name ] - -- - -- element_declaration ::= - -- identifier_list : element_subtype_definition - -- - -- element_subtype_definition ::= subtype_indication - function Parse_Record_Type_Definition return Iir_Record_Type_Definition - is - Res: Iir_Record_Type_Definition; - El_List : Iir_List; - El: Iir_Element_Declaration; - First : Iir; - Pos: Iir_Index32; - Subtype_Indication: Iir; - begin - Res := Create_Iir (Iir_Kind_Record_Type_Definition); - Set_Location (Res); - El_List := Create_Iir_List; - - -- Skip 'record' - Scan; - - Pos := 0; - First := Null_Iir; - loop - pragma Assert (First = Null_Iir); - -- Parse identifier_list - loop - El := Create_Iir (Iir_Kind_Element_Declaration); - Scan_Identifier (El); - - Set_Parent (El, Res); - if First = Null_Iir then - First := El; - end if; - - Append_Element (El_List, El); - Set_Element_Position (El, Pos); - Pos := Pos + 1; - - exit when Current_Token /= Tok_Comma; - - Set_Has_Identifier_List (El, True); - - -- Skip ',' - Scan; - end loop; - - -- Scan ':'. - Expect_Scan (Tok_Colon); - - -- Parse element subtype indication. - Subtype_Indication := Parse_Subtype_Indication; - Set_Subtype_Indication (First, Subtype_Indication); - - First := Null_Iir; - Scan_Semi_Colon_Declaration ("element declaration"); - exit when Current_Token /= Tok_Identifier; - end loop; - - Set_Elements_Declaration_List (Res, List_To_Flist (El_List)); - - if Flag_Elocations then - Create_Elocations (Res); - Set_End_Location (Res, Get_Token_Location); - end if; - - -- Skip 'end' - Expect_Scan (Tok_End); - Expect_Scan (Tok_Record); - Set_End_Has_Reserved_Id (Res, True); - - return Res; - end Parse_Record_Type_Definition; - - -- precond : ACCESS - -- postcond: ? - -- - -- [ LRM93 3.3] - -- access_type_definition ::= ACCESS subtype_indication. - function Parse_Access_Type_Definition return Iir_Access_Type_Definition - is - Res : Iir_Access_Type_Definition; - begin - Res := Create_Iir (Iir_Kind_Access_Type_Definition); - Set_Location (Res); - - -- Skip 'access' - Expect (Tok_Access); - Scan; - - Set_Designated_Subtype_Indication (Res, Parse_Subtype_Indication); - - return Res; - end Parse_Access_Type_Definition; - - -- precond : FILE - -- postcond: next token - -- - -- [ LRM93 3.4 ] - -- file_type_definition ::= FILE OF type_mark - function Parse_File_Type_Definition return Iir_File_Type_Definition - is - Res : Iir_File_Type_Definition; - Type_Mark: Iir; - begin - Res := Create_Iir (Iir_Kind_File_Type_Definition); - Set_Location (Res); - -- Accept token 'file'. - Scan; - Expect_Scan (Tok_Of); - - Type_Mark := Parse_Type_Mark (Check_Paren => True); - if Type_Mark = Null_Iir - or else Get_Kind (Type_Mark) not in Iir_Kinds_Denoting_Name - then - Error_Msg_Parse ("type mark expected"); - else - Set_File_Type_Mark (Res, Type_Mark); - end if; - return Res; - end Parse_File_Type_Definition; - - -- precond : PROTECTED - -- postcond: ';' - -- - -- [ 3.5 ] - -- protected_type_definition ::= protected_type_declaration - -- | protected_type_body - -- - -- [ 3.5.1 ] - -- protected_type_declaration ::= PROTECTED - -- protected_type_declarative_part - -- END PROTECTED [ simple_name ] - -- - -- protected_type_declarative_part ::= - -- { protected_type_declarative_item } - -- - -- protected_type_declarative_item ::= - -- subprogram_declaration - -- | attribute_specification - -- | use_clause - -- - -- [ 3.5.2 ] - -- protected_type_body ::= PROTECTED BODY - -- protected_type_body_declarative_part - -- END PROTECTED BODY [ simple_name ] - -- - -- protected_type_body_declarative_part ::= - -- { protected_type_body_declarative_item } - function Parse_Protected_Type_Definition - (Ident : Name_Id; Loc : Location_Type) return Iir - is - Res : Iir; - Decl : Iir; - begin - -- Skip 'protected'. - Scan; - - if Current_Token = Tok_Body then - Res := Create_Iir (Iir_Kind_Protected_Type_Body); - - -- Skip 'body'. - Scan; - - Decl := Res; - else - Decl := Create_Iir (Iir_Kind_Type_Declaration); - Res := Create_Iir (Iir_Kind_Protected_Type_Declaration); - Set_Location (Res, Loc); - Set_Type_Definition (Decl, Res); - end if; - Set_Identifier (Decl, Ident); - Set_Location (Decl, Loc); - - Parse_Declarative_Part (Res); - - -- Eat 'end'. - Expect_Scan (Tok_End); - - if Flags.Vhdl_Std >= Vhdl_00 then - Expect_Scan (Tok_Protected); - else - -- Avoid weird message: 'protected' expected instead of 'protected'. - Expect_Scan (Tok_Identifier); - end if; - Set_End_Has_Reserved_Id (Res, True); - if Get_Kind (Res) = Iir_Kind_Protected_Type_Body then - Expect_Scan (Tok_Body); - end if; - Check_End_Name (Ident, Res); - return Decl; - end Parse_Protected_Type_Definition; - - -- precond : TYPE - -- postcond: a token - -- - -- [ LRM93 4.1 ] - -- type_definition ::= scalar_type_definition - -- | composite_type_definition - -- | access_type_definition - -- | file_type_definition - -- | protected_type_definition - -- - -- [ LRM93 3.1 ] - -- scalar_type_definition ::= enumeration_type_definition - -- | integer_type_definition - -- | floating_type_definition - -- | physical_type_definition - -- - -- [ LRM93 3.2 ] - -- composite_type_definition ::= array_type_definition - -- | record_type_definition - -- - -- [ LRM93 3.1.2 ] - -- integer_type_definition ::= range_constraint - -- - -- [ LRM93 3.1.4 ] - -- floating_type_definition ::= range_constraint - function Parse_Type_Declaration (Parent : Iir) return Iir - is - Def : Iir; - Loc : Location_Type; - Ident : Name_Id; - Decl : Iir; - Start_Loc : Location_Type; - begin - -- The current token must be type. - pragma Assert (Current_Token = Tok_Type); - Start_Loc := Get_Token_Location; - - -- Skip 'type'. - Scan; - - -- Get the identifier - Loc := Get_Token_Location; - if Current_Token = Tok_Identifier then - Ident := Current_Identifier; - - -- Skip identifier. - Scan; - else - Expect (Tok_Identifier, "identifier is expected after 'type'"); - Ident := Null_Identifier; - end if; - - - if Current_Token = Tok_Semi_Colon then - -- If there is a ';', this is an incomplete type declaration. - Scan; - - Decl := Create_Iir (Iir_Kind_Type_Declaration); - Set_Identifier (Decl, Ident); - Set_Location (Decl, Loc); - - if Flag_Elocations then - Create_Elocations (Decl); - Set_Start_Location (Decl, Start_Loc); - end if; - - return Decl; - end if; - - Expect_Scan (Tok_Is, "'is' expected here"); - - case Current_Token is - when Tok_Left_Paren => - -- This is an enumeration. - Def := Parse_Enumeration_Type_Definition (Parent); - Decl := Null_Iir; - - when Tok_Range => - -- This is a range definition. - Decl := Create_Iir (Iir_Kind_Anonymous_Type_Declaration); - Set_Identifier (Decl, Ident); - Set_Location (Decl, Loc); - - -- Skip 'range' - Scan; - - Def := Parse_Range_Constraint; - Set_Type_Definition (Decl, Def); - - if Current_Token = Tok_Units then - -- A physical type definition. - declare - Phys_Def : Iir; - begin - Phys_Def := Parse_Physical_Type_Definition (Parent); - if Current_Token = Tok_Identifier then - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse - ("simple_name not allowed here in vhdl87"); - end if; - Check_End_Name (Get_Identifier (Decl), Phys_Def); - end if; - Set_Range_Constraint (Phys_Def, Def); - Set_Type_Definition (Decl, Phys_Def); - end; - end if; - - when Tok_Array => - Def := Parse_Array_Type_Definition; - Decl := Null_Iir; - - when Tok_Record => - Decl := Create_Iir (Iir_Kind_Type_Declaration); - Set_Identifier (Decl, Ident); - Set_Location (Decl, Loc); - Def := Parse_Record_Type_Definition; - Set_Type_Definition (Decl, Def); - if Current_Token = Tok_Identifier then - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse ("simple_name not allowed here in vhdl87"); - end if; - Check_End_Name (Get_Identifier (Decl), Def); - end if; - - when Tok_Access => - Def := Parse_Access_Type_Definition; - Decl := Null_Iir; - - when Tok_File => - Def := Parse_File_Type_Definition; - Decl := Null_Iir; - - when Tok_Identifier => - if Current_Identifier = Name_Protected then - Error_Msg_Parse ("protected type not allowed in vhdl87/93"); - Decl := Parse_Protected_Type_Definition (Ident, Loc); - else - Error_Msg_Parse ("type %i cannot be defined from another type", - (1 => +Ident), Cont => True); - Error_Msg_Parse ("(you should declare a subtype)"); - Decl := Create_Iir (Iir_Kind_Type_Declaration); - end if; - - when Tok_Protected => - if Flags.Vhdl_Std < Vhdl_00 then - Error_Msg_Parse ("protected type not allowed in vhdl87/93"); - end if; - Decl := Parse_Protected_Type_Definition (Ident, Loc); - - when others => - Error_Msg_Parse ("missing type definition after 'is'"); - Decl := Create_Iir (Iir_Kind_Type_Declaration); - end case; - - if Decl = Null_Iir then - case Get_Kind (Def) is - when Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Access_Type_Definition - | Iir_Kind_Array_Type_Definition - | Iir_Kind_File_Type_Definition => - Decl := Create_Iir (Iir_Kind_Type_Declaration); - when Iir_Kind_Array_Subtype_Definition => - Decl := Create_Iir (Iir_Kind_Anonymous_Type_Declaration); - when others => - Error_Kind ("parse_type_declaration", Def); - end case; - Set_Type_Definition (Decl, Def); - end if; - Set_Identifier (Decl, Ident); - Set_Location (Decl, Loc); - - -- ';' is expected after end of type declaration - Scan_Semi_Colon_Declaration ("type declaration"); - - if Flag_Elocations then - Create_Elocations (Decl); - Set_Start_Location (Decl, Start_Loc); - end if; - - return Decl; - end Parse_Type_Declaration; - - -- precond: '(' or identifier - -- postcond: next token - -- - -- [ LRM08 6.3 ] - -- - -- resolution_indication ::= - -- resolution_function_name | ( element_resolution ) - -- - -- element_resolution ::= - -- array_element_resolution | record_resolution - -- - -- array_element_resolution ::= resolution_indication - -- - -- record_resolution ::= - -- record_element_resolution { , record_element_resolution } - -- - -- record_element_resolution ::= - -- record_element_simple_name resolution_indication - function Parse_Resolution_Indication return Iir - is - Ind : Iir; - Def : Iir; - Loc : Location_Type; - begin - if Current_Token = Tok_Identifier then - -- Resolution function name. - return Parse_Name (Allow_Indexes => False); - elsif Current_Token = Tok_Left_Paren then - -- Element resolution. - Loc := Get_Token_Location; - - -- Eat '(' - Scan; - - Ind := Parse_Resolution_Indication; - if Current_Token = Tok_Identifier - or else Current_Token = Tok_Left_Paren - then - declare - Id : Name_Id; - El : Iir; - First, Last : Iir; - begin - -- This was in fact a record_resolution. - if Get_Kind (Ind) = Iir_Kind_Simple_Name then - Id := Get_Identifier (Ind); - else - Error_Msg_Parse (+Ind, "element name expected"); - Id := Null_Identifier; - end if; - Free_Iir (Ind); - - Def := Create_Iir (Iir_Kind_Record_Resolution); - Set_Location (Def, Loc); - Sub_Chain_Init (First, Last); - loop - El := Create_Iir (Iir_Kind_Record_Element_Resolution); - Set_Location (El, Loc); - Set_Identifier (El, Id); - Set_Resolution_Indication (El, Parse_Resolution_Indication); - Sub_Chain_Append (First, Last, El); - exit when Current_Token /= Tok_Comma; - - -- Eat ',' - Scan; - - if Current_Token /= Tok_Identifier then - Error_Msg_Parse ("record element identifier expected"); - exit; - end if; - Id := Current_Identifier; - Loc := Get_Token_Location; - - -- Eat identifier - Scan; - end loop; - Set_Record_Element_Resolution_Chain (Def, First); - end; - else - Def := Create_Iir (Iir_Kind_Array_Element_Resolution); - Set_Location (Def, Loc); - Set_Resolution_Indication (Def, Ind); - end if; - - -- Eat ')' - Expect_Scan (Tok_Right_Paren); - - return Def; - else - Error_Msg_Parse ("resolution indication expected"); - return Null_Iir; - end if; - end Parse_Resolution_Indication; - - -- precond : '(' - -- postcond: next token - -- - -- [ LRM08 6.3 Subtype declarations ] - -- element_constraint ::= - -- array_constraint | record_constraint - -- - -- [ LRM08 5.3.2.1 Array types ] - -- array_constraint ::= - -- index_constraint [ array_element_constraint ] - -- | ( open ) [ array_element_constraint ] - -- - -- array_element_constraint ::= element_constraint - -- - -- RES is the resolution_indication of the subtype indication. - function Parse_Element_Constraint return Iir - is - Def : Iir; - El : Iir; - Index_List : Iir_List; - begin - -- Index_constraint. - Def := Create_Iir (Iir_Kind_Array_Subtype_Definition); - Set_Location (Def); - - -- Eat '('. - Scan; - - if Current_Token = Tok_Open then - -- Eat 'open'. - Scan; - else - Index_List := Create_Iir_List; - -- index_constraint ::= (discrete_range {, discrete_range} ) - loop - El := Parse_Discrete_Range; - Append_Element (Index_List, El); - - exit when Current_Token /= Tok_Comma; - - -- Eat ',' - Scan; - end loop; - Set_Index_Constraint_List (Def, List_To_Flist (Index_List)); - end if; - - -- Eat ')' - Expect_Scan (Tok_Right_Paren); - - if Current_Token = Tok_Left_Paren then - Set_Array_Element_Constraint (Def, Parse_Element_Constraint); - end if; - return Def; - end Parse_Element_Constraint; - - -- precond : tolerance - -- postcond: next token - -- - -- [ LRM93 4.2 ] - -- tolerance_aspect ::= TOLERANCE string_expression - function Parse_Tolerance_Aspect_Opt return Iir is - begin - if AMS_Vhdl - and then Current_Token = Tok_Tolerance - then - Scan; - return Parse_Expression; - else - return Null_Iir; - end if; - end Parse_Tolerance_Aspect_Opt; - - -- precond : identifier or '(' - -- postcond: next token - -- - -- [ LRM93 4.2 ] - -- subtype_indication ::= - -- [ RESOLUTION_FUNCTION_name ] type_mark [ constraint ] - -- - -- constraint ::= range_constraint | index_constraint - -- - -- [ LRM08 6.3 ] - -- subtype_indication ::= - -- [ resolution_indication ] type_mark [ constraint ] - -- - -- constraint ::= - -- range_constraint | array_constraint | record_constraint - -- - -- NAME is the type_mark when already parsed (in range expression or - -- allocator by type). - function Parse_Subtype_Indication (Name : Iir := Null_Iir) return Iir - is - Type_Mark : Iir; - Def: Iir; - Resolution_Indication: Iir; - Tolerance : Iir; - begin - -- FIXME: location. - Resolution_Indication := Null_Iir; - Def := Null_Iir; - - if Name /= Null_Iir then - -- The type_mark was already parsed. - Type_Mark := Name; - Check_Type_Mark (Name); - else - if Current_Token = Tok_Left_Paren then - if Vhdl_Std < Vhdl_08 then - Error_Msg_Parse - ("resolution_indication not allowed before vhdl08"); - end if; - Resolution_Indication := Parse_Resolution_Indication; - end if; - if Current_Token /= Tok_Identifier then - Error_Msg_Parse ("type mark expected in a subtype indication"); - return Create_Error_Node; - end if; - Type_Mark := Parse_Type_Mark (Check_Paren => False); - end if; - - if Current_Token = Tok_Identifier then - if Resolution_Indication /= Null_Iir then - Error_Msg_Parse ("resolution function already indicated"); - end if; - Resolution_Indication := Type_Mark; - Type_Mark := Parse_Type_Mark (Check_Paren => False); - end if; - - case Current_Token is - when Tok_Left_Paren => - -- element_constraint. - Def := Parse_Element_Constraint; - Set_Subtype_Type_Mark (Def, Type_Mark); - Set_Resolution_Indication (Def, Resolution_Indication); - Set_Tolerance (Def, Parse_Tolerance_Aspect_Opt); - - when Tok_Range => - -- range_constraint. - -- Skip 'range' - Scan; - - Def := Parse_Range_Constraint_Of_Subtype_Indication - (Type_Mark, Resolution_Indication); - - when others => - Tolerance := Parse_Tolerance_Aspect_Opt; - if Resolution_Indication /= Null_Iir - or else Tolerance /= Null_Iir - then - -- A subtype needs to be created. - Def := Create_Iir (Iir_Kind_Subtype_Definition); - if Type_Mark /= Null_Iir then - Location_Copy (Def, Type_Mark); - Set_Subtype_Type_Mark (Def, Type_Mark); - end if; - Set_Resolution_Indication (Def, Resolution_Indication); - Set_Tolerance (Def, Tolerance); - else - -- This is just an alias. - Def := Type_Mark; - end if; - end case; - return Def; - end Parse_Subtype_Indication; - - -- precond : SUBTYPE - -- postcond: next token - -- - -- [ LRM93 4.2 ] - -- subtype_declaration ::= SUBTYPE identifier IS subtype_indication ; - function Parse_Subtype_Declaration (Parent : Iir) - return Iir_Subtype_Declaration - is - Decl: Iir_Subtype_Declaration; - Def: Iir; - Start_Loc : Location_Type; - begin - Decl := Create_Iir (Iir_Kind_Subtype_Declaration); - Set_Parent (Decl, Parent); - Start_Loc := Get_Token_Location; - - -- Eat 'subtype'. - Scan; - - Scan_Identifier (Decl); - - -- Skip 'is'. - Expect_Scan (Tok_Is); - - Def := Parse_Subtype_Indication; - Set_Subtype_Indication (Decl, Def); - - -- Skip ';'. - Scan_Semi_Colon_Declaration ("subtype decalaration"); - - if Flag_Elocations then - Create_Elocations (Decl); - Set_Start_Location (Decl, Start_Loc); - end if; - - return Decl; - end Parse_Subtype_Declaration; - - -- precond : NATURE - -- postcond: a token - -- - -- [ LRM93 4.8 ] - -- nature_definition ::= scalar_nature_definition - -- | composite_nature_definition - -- - -- [ LRM93 3.5.1 ] - -- scalar_nature_definition ::= type_mark ACROSS - -- type_mark THROUGH - -- identifier REFERENCE - -- - -- [ LRM93 3.5.2 ] - -- composite_nature_definition ::= array_nature_definition - -- | record_nature_definition - function Parse_Nature_Declaration return Iir - is - Def : Iir; - Ref : Iir; - Loc : Location_Type; - Ident : Name_Id; - Decl : Iir; - begin - -- Skip 'nature'. - pragma Assert (Current_Token = Tok_Nature); - Scan; - - -- Get the identifier - Expect (Tok_Identifier, - "an identifier is expected after 'nature'"); - Loc := Get_Token_Location; - Ident := Current_Identifier; - - Scan; - - -- Skip 'is'. - Expect_Scan (Tok_Is); - - case Current_Token is - when Tok_Array => - -- TODO - Error_Msg_Parse ("array nature definition not supported"); - Def := Null_Iir; - Skip_Until_Semi_Colon; - when Tok_Record => - -- TODO - Error_Msg_Parse ("record nature definition not supported"); - Def := Null_Iir; - Skip_Until_Semi_Colon; - when Tok_Identifier => - Def := Create_Iir (Iir_Kind_Scalar_Nature_Definition); - Set_Location (Def, Loc); - Set_Across_Type (Def, Parse_Type_Mark); - if Current_Token = Tok_Across then - Scan; - else - Expect (Tok_Across, "'across' expected after type mark"); - end if; - Set_Through_Type (Def, Parse_Type_Mark); - if Current_Token = Tok_Through then - Scan; - else - Expect (Tok_Across, "'through' expected after type mark"); - end if; - if Current_Token = Tok_Identifier then - Ref := Create_Iir (Iir_Kind_Terminal_Declaration); - Scan_Identifier (Ref); - Set_Reference (Def, Ref); - if Current_Token = Tok_Reference then - Scan; - else - Expect (Tok_Reference, "'reference' expected"); - Skip_Until_Semi_Colon; - end if; - else - Error_Msg_Parse ("reference identifier expected"); - Skip_Until_Semi_Colon; - end if; - when others => - Error_Msg_Parse ("nature definition expected here"); - Skip_Until_Semi_Colon; - end case; - - Decl := Create_Iir (Iir_Kind_Nature_Declaration); - Set_Nature (Decl, Def); - Set_Identifier (Decl, Ident); - Set_Location (Decl, Loc); - - -- ';' is expected after end of type declaration - Scan_Semi_Colon_Declaration ("nature declaration"); - - return Decl; - end Parse_Nature_Declaration; - - -- precond : identifier - -- postcond: next token - -- - -- LRM 4.8 Nature declaration - -- - -- subnature_indication ::= - -- nature_mark [ index_constraint ] - -- [ TOLERANCE string_expression ACROSS string_expression THROUGH ] - -- - -- nature_mark ::= - -- nature_name | subnature_name - function Parse_Subnature_Indication return Iir - is - Nature_Mark : Iir; - begin - if Current_Token /= Tok_Identifier then - Error_Msg_Parse ("nature mark expected in a subnature indication"); - return Null_Iir; - end if; - Nature_Mark := Parse_Name (Allow_Indexes => False); - - if Current_Token = Tok_Left_Paren then - -- TODO - Error_Msg_Parse - ("index constraint not supported for subnature indication"); - raise Internal_Error; - end if; - - if Current_Token = Tok_Tolerance then - Error_Msg_Parse ("tolerance not supported for subnature indication"); - raise Internal_Error; - end if; - return Nature_Mark; - end Parse_Subnature_Indication; - - -- precond : TERMINAL - -- postcond: next token. - -- - -- [ 4.3.1.5 Terminal declarations ] - -- terminal_declaration ::= - -- TERMINAL identifier_list : subnature_indication - function Parse_Terminal_Declaration (Parent : Iir) return Iir - is - -- First and last element of the chain to be returned. - First, Last : Iir; - Terminal : Iir; - Subnature : Iir; - begin - Sub_Chain_Init (First, Last); - - -- Skip 'terminal'. - Scan; - - loop - -- 'terminal' or "," was just scanned. - Terminal := Create_Iir (Iir_Kind_Terminal_Declaration); - - Scan_Identifier (Terminal); - - Set_Parent (Terminal, Parent); - - Sub_Chain_Append (First, Last, Terminal); - - exit when Current_Token /= Tok_Comma; - -- Skip ','. - Scan; - end loop; - - -- Skip ':'. - Expect_Scan (Tok_Colon); - - Subnature := Parse_Subnature_Indication; - - Terminal := First; - while Terminal /= Null_Iir loop - -- Type definitions are factorized. This is OK, but not done by - -- sem. - if Terminal = First then - Set_Nature (Terminal, Subnature); - else - Set_Nature (Terminal, Null_Iir); - end if; - Terminal := Get_Chain (Terminal); - end loop; - - -- Skip ';'. - Scan_Semi_Colon_Declaration ("terminal declaration"); - - return First; - end Parse_Terminal_Declaration; - - -- precond : QUANTITY - -- postcond: next token. - -- - -- [ 4.3.1.6 Quantity declarations ] - -- quantity_declaration ::= - -- free_quantity_declaration - -- | branch_quantity_declaration - -- | source_quantity_declaration - -- - -- free_quantity_declaration ::= - -- QUANTITY identifier_list : subtype_indication [ := expression ] ; - -- - -- branch_quantity_declaration ::= - -- QUANTITY [ across_aspect ] [ through_aspect ] terminal_aspect ; - -- - -- source_quantity_declaration ::= - -- QUANTITY identifier_list : subtype_indication source_aspect ; - -- - -- across_aspect ::= - -- identifier_list [ tolerance_aspect ] [ := expression ] ACROSS - -- - -- through_aspect ::= - -- identifier_list [ tolerance_aspect ] [ := expression ] THROUGH - -- - -- terminal_aspect ::= - -- plus_terminal_name [ TO minus_terminal_name ] - function Parse_Quantity_Declaration (Parent : Iir) return Iir - is - -- First and last element of the chain to be returned. - First, Last : Iir; - Object : Iir; - New_Object : Iir; - Tolerance : Iir; - Default_Value : Iir; - Kind : Iir_Kind; - Plus_Terminal : Iir; - begin - Sub_Chain_Init (First, Last); - - -- Eat 'quantity' - Scan; - - loop - -- Quantity or "," was just scanned. We assume a free quantity - -- declaration and will change to branch or source quantity if - -- necessary. - Object := Create_Iir (Iir_Kind_Free_Quantity_Declaration); - - Scan_Identifier (Object); - - Set_Parent (Object, Parent); - - Sub_Chain_Append (First, Last, Object); - - exit when Current_Token /= Tok_Comma; - - -- Eat ',' - Scan; - end loop; - - case Current_Token is - when Tok_Colon => - -- Either a free quantity (or a source quantity) - -- TODO - raise Program_Error; - when Tok_Tolerance - | Tok_Assign - | Tok_Across - | Tok_Through => - -- A branch quantity - - -- Parse tolerance aspect - Tolerance := Parse_Tolerance_Aspect_Opt; - - -- Parse default value - if Current_Token = Tok_Assign then - Scan; - Default_Value := Parse_Expression; - else - Default_Value := Null_Iir; - end if; - - case Current_Token is - when Tok_Across => - Kind := Iir_Kind_Across_Quantity_Declaration; - when Tok_Through => - Kind := Iir_Kind_Through_Quantity_Declaration; - when others => - Error_Msg_Parse ("'across' or 'through' expected here"); - Skip_Until_Semi_Colon; - return Null_Iir; - end case; - - -- Eat across/through - Scan; - - -- Change declarations - Object := First; - Sub_Chain_Init (First, Last); - while Object /= Null_Iir loop - New_Object := Create_Iir (Kind); - Location_Copy (New_Object, Object); - Set_Identifier (New_Object, Get_Identifier (Object)); - Set_Parent (New_Object, Parent); - Set_Tolerance (New_Object, Tolerance); - Set_Default_Value (New_Object, Default_Value); - - Sub_Chain_Append (First, Last, New_Object); - - if Object /= First then - Set_Plus_Terminal (New_Object, Null_Iir); - end if; - New_Object := Get_Chain (Object); - Free_Iir (Object); - Object := New_Object; - end loop; - - -- Parse terminal (or first identifier of through declarations) - Plus_Terminal := Parse_Name; - - case Current_Token is - when Tok_Comma - | Tok_Tolerance - | Tok_Assign - | Tok_Through - | Tok_Across => - -- Through quantity declaration. Convert the Plus_Terminal - -- to a declaration. - Object := Create_Iir (Iir_Kind_Through_Quantity_Declaration); - New_Object := Object; - Location_Copy (Object, Plus_Terminal); - if Get_Kind (Plus_Terminal) /= Iir_Kind_Simple_Name then - Error_Msg_Parse - ("identifier for quantity declaration expected"); - else - Set_Identifier (Object, Get_Identifier (Plus_Terminal)); - end if; - Set_Plus_Terminal (Object, Null_Iir); - Free_Iir (Plus_Terminal); - - loop - Set_Parent (Object, Parent); - Sub_Chain_Append (First, Last, Object); - exit when Current_Token /= Tok_Comma; - -- Skip ','. - Scan; - - Object := Create_Iir - (Iir_Kind_Through_Quantity_Declaration); - Scan_Identifier (Object); - Set_Plus_Terminal (Object, Null_Iir); - - end loop; - - -- Parse tolerance aspect - Set_Tolerance (Object, Parse_Tolerance_Aspect_Opt); - - -- Parse default value - if Current_Token = Tok_Assign then - Scan; - Set_Default_Value (Object, Parse_Expression); - end if; - - -- Scan 'through' - if Current_Token = Tok_Through then - Scan; - elsif Current_Token = Tok_Across then - Error_Msg_Parse ("across quantity declaration must appear" - & " before though declaration"); - Scan; - else - Error_Msg_Parse ("'through' expected"); - end if; - - -- Parse plus terminal - Plus_Terminal := Parse_Name; - when others => - null; - end case; - - Set_Plus_Terminal (First, Plus_Terminal); - - -- Parse minus terminal (if present) - if Current_Token = Tok_To then - Scan; - Set_Minus_Terminal (First, Parse_Name); - end if; - when others => - Error_Msg_Parse ("missing type or across/throught aspect " - & "in quantity declaration"); - Skip_Until_Semi_Colon; - return Null_Iir; - end case; - - -- Skip ';'. - Scan_Semi_Colon_Declaration ("quantity declaration"); - - return First; - end Parse_Quantity_Declaration; - - -- precond : token (CONSTANT, SIGNAL, VARIABLE, FILE) - -- postcond: next token. - -- - -- KIND can be iir_kind_constant_declaration, iir_kind_file_declaration - -- or iir_kind_variable_declaration - -- - -- [ LRM93 4.3.1 ] - -- object_declaration ::= constant_declaration - -- | signal_declaration - -- | variable_declaration - -- | file_declaration - -- - -- [ LRM93 4.3.1.1 ] - -- constant_declaration ::= - -- CONSTANT identifier_list : subtype_indication [ := expression ] - -- - -- [ LRM87 4.3.2 ] - -- file_declaration ::= - -- FILE identifier : subtype_indication IS [ mode ] file_logical_name - -- - -- [ LRM93 4.3.1.4 ] - -- file_declaration ::= - -- FILE identifier_list : subtype_indication [ file_open_information ] - -- - -- [ LRM93 4.3.1.4 ] - -- file_open_information ::= - -- [ OPEN FILE_OPEN_KIND_expression ] IS file_logical_name - -- - -- [ LRM93 4.3.1.4 ] - -- file_logical_name ::= STRING_expression - -- - -- [ LRM93 4.3.1.3 ] - -- variable_declaration ::= - -- [ SHARED ] VARIABLE identifier_list : subtype_indication - -- [ := expression ] - -- - -- [ LRM93 4.3.1.2 ] - -- signal_declaration ::= - -- SIGNAL identifier_list : subtype_information [ signal_kind ] - -- [ := expression ] - -- - -- [ LRM93 4.3.1.2 ] - -- signal_kind ::= REGISTER | BUS - -- - -- FIXME: file_open_information. - function Parse_Object_Declaration (Parent : Iir) return Iir - is - -- First and last element of the chain to be returned. - First, Last : Iir; - Object: Iir; - Object_Type: Iir; - Default_Value : Iir; - Mode: Iir_Mode; - Signal_Kind : Iir_Signal_Kind; - Is_Guarded : Boolean; - Open_Kind : Iir; - Logical_Name : Iir; - Kind: Iir_Kind; - Shared : Boolean; - Has_Mode : Boolean; - Start_Loc : Location_Type; - begin - Sub_Chain_Init (First, Last); - - -- Object keyword was just scanned. - Start_Loc := Get_Token_Location; - case Current_Token is - when Tok_Signal => - Kind := Iir_Kind_Signal_Declaration; - - -- Skip 'signal'. - Scan; - - when Tok_Constant => - Kind := Iir_Kind_Constant_Declaration; - - -- Skip 'constant'. - Scan; - - when Tok_File => - Kind := Iir_Kind_File_Declaration; - - -- Skip 'file'. - Scan; - - when Tok_Variable => - Kind := Iir_Kind_Variable_Declaration; - Shared := False; - - -- Skip 'variable'. - Scan; - - when Tok_Shared => - Kind := Iir_Kind_Variable_Declaration; - Shared := True; - - -- Skip 'shared'. - Scan; - - Expect_Scan (Tok_Variable); - when others => - raise Internal_Error; - end case; - - loop - -- Object or "," was just scanned. - Object := Create_Iir (Kind); - if Kind = Iir_Kind_Variable_Declaration then - Set_Shared_Flag (Object, Shared); - end if; - - Scan_Identifier (Object); - - Set_Parent (Object, Parent); - - if Flag_Elocations then - Create_Elocations (Object); - Set_Start_Location (Object, Start_Loc); - end if; - - Sub_Chain_Append (First, Last, Object); - - exit when Current_Token /= Tok_Comma; - - -- Skip ','. - Scan; - Set_Has_Identifier_List (Object, True); - end loop; - - -- Skip ':'. - Expect_Scan (Tok_Colon); - - Object_Type := Parse_Subtype_Indication; - - if Kind = Iir_Kind_Signal_Declaration then - Parse_Signal_Kind (Is_Guarded, Signal_Kind); - end if; - - if Current_Token = Tok_Assign then - if Kind = Iir_Kind_File_Declaration then - Error_Msg_Parse - ("default expression not allowed for a file declaration"); - end if; - - -- Skip ':='. - Scan; - - Default_Value := Parse_Expression; - elsif Current_Token = Tok_Equal then - Error_Msg_Parse ("= should be := for initial value"); - - -- Skip '=' - Scan; - - Default_Value := Parse_Expression; - else - Default_Value := Null_Iir; - end if; - - if Kind = Iir_Kind_File_Declaration then - if Current_Token = Tok_Open then - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse - ("'open' and open kind expression not allowed in vhdl 87"); - end if; - Scan; - Open_Kind := Parse_Expression; - else - Open_Kind := Null_Iir; - end if; - - -- LRM 4.3.1.4 - -- The default mode is IN, if no mode is specified. - Mode := Iir_In_Mode; - - Logical_Name := Null_Iir; - Has_Mode := False; - if Current_Token = Tok_Is then - -- Skip 'is'. - Scan; - - case Current_Token is - when Tok_In | Tok_Out | Tok_Inout => - if Flags.Vhdl_Std >= Vhdl_93 then - Error_Msg_Parse ("mode allowed only in vhdl 87"); - end if; - Mode := Parse_Mode; - if Mode = Iir_Inout_Mode then - Error_Msg_Parse ("inout mode not allowed for file"); - end if; - Has_Mode := True; - when others => - null; - end case; - Logical_Name := Parse_Expression; - elsif Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse ("file name expected (vhdl 87)"); - end if; - end if; - - Set_Subtype_Indication (First, Object_Type); - if Kind /= Iir_Kind_File_Declaration then - Set_Default_Value (First, Default_Value); - end if; - - Object := First; - while Object /= Null_Iir loop - case Kind is - when Iir_Kind_File_Declaration => - Set_Mode (Object, Mode); - Set_File_Open_Kind (Object, Open_Kind); - Set_File_Logical_Name (Object, Logical_Name); - Set_Has_Mode (Object, Has_Mode); - when Iir_Kind_Signal_Declaration => - Set_Guarded_Signal_Flag (Object, Is_Guarded); - Set_Signal_Kind (Object, Signal_Kind); - when others => - null; - end case; - Object := Get_Chain (Object); - end loop; - - -- Skip ';'. - Scan_Semi_Colon_Declaration ("object declaration"); - - return First; - end Parse_Object_Declaration; - - -- precond : COMPONENT - -- postcond: next token. - -- - -- [ LRM93 4.5 ] - -- component_declaration ::= - -- COMPONENT identifier [ IS ] - -- [ LOCAL_generic_clause ] - -- [ LOCAL_port_clause ] - -- END COMPONENT [ COMPONENT_simple_name ] ; - function Parse_Component_Declaration return Iir_Component_Declaration - is - Component : Iir_Component_Declaration; - begin - Component := Create_Iir (Iir_Kind_Component_Declaration); - if Flag_Elocations then - Create_Elocations (Component); - Set_Start_Location (Component, Get_Token_Location); - end if; - - -- Eat 'component'. - pragma Assert (Current_Token = Tok_Component); - Scan; - - Scan_Identifier (Component); - - if Current_Token = Tok_Is then - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse ("""is"" keyword is not allowed here by vhdl 87"); - end if; - Set_Has_Is (Component, True); - - -- Eat 'is'. - Scan; - end if; - Parse_Generic_Port_Clauses (Component); - - if Flag_Elocations then - Set_End_Location (Component, Get_Token_Location); - end if; - - Check_End_Name (Tok_Component, Component); - - -- Skip ';'. - Expect_Scan (Tok_Semi_Colon); - - return Component; - end Parse_Component_Declaration; - - -- precond : '[' - -- postcond: next token after ']' - -- - -- [ LRM93 2.3.2 ] - -- signature ::= [ [ type_mark { , type_mark } ] [ RETURN type_mark ] ] - function Parse_Signature return Iir_Signature - is - Res : Iir_Signature; - List : Iir_List; - begin - Expect (Tok_Left_Bracket); - Res := Create_Iir (Iir_Kind_Signature); - Set_Location (Res); - - -- Skip '[' - Scan; - - -- List of type_marks. - if Current_Token = Tok_Identifier then - List := Create_Iir_List; - loop - Append_Element (List, Parse_Type_Mark (Check_Paren => True)); - exit when Current_Token /= Tok_Comma; - - -- Skip ','. - Scan; - end loop; - Set_Type_Marks_List (Res, List_To_Flist (List)); - end if; - - if Current_Token = Tok_Return then - -- Skip 'return' - Scan; - - Set_Return_Type_Mark (Res, Parse_Name); - end if; - - -- Skip ']' - Expect (Tok_Right_Bracket); - Scan; - - return Res; - end Parse_Signature; - - -- precond : ALIAS - -- postcond: next token - -- - -- [ LRM93 4.3.3 ] - -- alias_declaration ::= - -- ALIAS alias_designator [ : subtype_indication ] - -- IS name [ signature ] ; - -- - -- [ LRM93 4.3.3 ] - -- alias_designator ::= identifier | character_literal | operator_symbol - -- - -- FIXME: signature is not part of the node. - function Parse_Alias_Declaration return Iir - is - Res: Iir; - Ident : Name_Id; - Start_Loc : Location_Type; - begin - Start_Loc := Get_Token_Location; - - -- Skip 'alias'. - pragma Assert (Current_Token = Tok_Alias); - Scan; - - Res := Create_Iir (Iir_Kind_Object_Alias_Declaration); - Set_Location (Res); - - case Current_Token is - when Tok_Identifier - | Tok_Character => - Ident := Current_Identifier; - - -- Skip identifier/character. - Scan; - when Tok_String => - Ident := Scan_To_Operator_Name (Get_Token_Location); - - -- Skip operator. - Scan; - -- FIXME: vhdl87 - -- FIXME: operator symbol. - when others => - Error_Msg_Parse ("alias designator expected"); - Ident := Null_Identifier; - end case; - Set_Identifier (Res, Ident); - - if Current_Token = Tok_Colon then - -- Skip ':'. - Scan; - Set_Subtype_Indication (Res, Parse_Subtype_Indication); - end if; - - -- FIXME: nice message if token is ':=' ? - Expect_Scan (Tok_Is); - Set_Name (Res, Parse_Signature_Name); - - if Flag_Elocations then - Create_Elocations (Res); - Set_Start_Location (Res, Start_Loc); - end if; - - -- Skip ';'. - Scan_Semi_Colon_Declaration ("alias declaration"); - - return Res; - end Parse_Alias_Declaration; - - -- precond : FOR - -- postcond: next token. - -- - -- [ LRM93 5.2 ] - -- configuration_specification ::= - -- FOR component_specification binding_indication ; - function Parse_Configuration_Specification - return Iir_Configuration_Specification - is - Res : Iir_Configuration_Specification; - begin - Res := Create_Iir (Iir_Kind_Configuration_Specification); - Set_Location (Res); - - -- Eat 'for'. - Expect_Scan (Tok_For); - - Parse_Component_Specification (Res); - Set_Binding_Indication (Res, Parse_Binding_Indication); - - -- Skip ';'. - Scan_Semi_Colon_Declaration ("configuration specification"); - - return Res; - end Parse_Configuration_Specification; - - -- precond : next token - -- postcond: next token - -- - -- [ LRM93 5.2 ] - -- entity_class := ENTITY | ARCHITECTURE | CONFIGURATION | PROCEDURE - -- | FUNCTION | PACKAGE | TYPE | SUBTYPE | CONSTANT - -- | SIGNAL | VARIABLE | COMPONENT | LABEL | LITERAL - -- | UNITS | GROUP | FILE - function Parse_Entity_Class return Token_Type - is - Res : Token_Type; - begin - case Current_Token is - when Tok_Entity - | Tok_Architecture - | Tok_Configuration - | Tok_Procedure - | Tok_Function - | Tok_Package - | Tok_Type - | Tok_Subtype - | Tok_Constant - | Tok_Signal - | Tok_Variable - | Tok_Component - | Tok_Label => - null; - when Tok_Literal - | Tok_Units - | Tok_Group - | Tok_File => - null; - when others => - Error_Msg_Parse ("%t is not a entity class", +Current_Token); - end case; - Res := Current_Token; - Scan; - return Res; - end Parse_Entity_Class; - - function Parse_Entity_Class_Entry return Iir_Entity_Class - is - Res : Iir_Entity_Class; - begin - Res := Create_Iir (Iir_Kind_Entity_Class); - Set_Location (Res); - Set_Entity_Class (Res, Parse_Entity_Class); - return Res; - end Parse_Entity_Class_Entry; - - -- precond : next token - -- postcond: next token - -- - -- [ LRM93 5.1 ] - -- entity_designator ::= entity_tag [ signature ] - -- - -- entity_tag ::= simple_name | character_literal | operator_symbol - function Parse_Entity_Designator return Iir - is - Res : Iir; - Name : Iir; - begin - case Current_Token is - when Tok_Identifier => - Res := Create_Iir (Iir_Kind_Simple_Name); - Set_Location (Res); - Set_Identifier (Res, Current_Identifier); - when Tok_Character => - Res := Create_Iir (Iir_Kind_Character_Literal); - Set_Location (Res); - Set_Identifier (Res, Current_Identifier); - when Tok_String => - Res := Create_Iir (Iir_Kind_Operator_Symbol); - Set_Location (Res); - Set_Identifier (Res, Scan_To_Operator_Name (Get_Token_Location)); - when others => - Error_Msg_Parse ("identifier, character or string expected"); - return Create_Error_Node; - end case; - Scan; - if Current_Token = Tok_Left_Bracket then - Name := Res; - Res := Parse_Signature; - Set_Signature_Prefix (Res, Name); - end if; - return Res; - end Parse_Entity_Designator; - - -- precond : next token - -- postcond: IS - -- - -- [ LRM93 5.1 ] - -- entity_name_list ::= entity_designator { , entity_designator } - -- | OTHERS - -- | ALL - procedure Parse_Entity_Name_List - (Attribute : Iir_Attribute_Specification) - is - List : Iir_List; - Flist : Iir_Flist; - El : Iir; - begin - case Current_Token is - when Tok_All => - Flist := Iir_Flist_All; - - -- Skip 'all'. - Scan; - - when Tok_Others => - Flist := Iir_Flist_Others; - - -- Skip 'others'. - Scan; - - when others => - List := Create_Iir_List; - loop - El := Parse_Entity_Designator; - Append_Element (List, El); - exit when Current_Token /= Tok_Comma; - Scan; - end loop; - Flist := List_To_Flist (List); - end case; - Set_Entity_Name_List (Attribute, Flist); - if Current_Token = Tok_Colon then - Scan; - Set_Entity_Class (Attribute, Parse_Entity_Class); - else - Error_Msg_Parse - ("missing ':' and entity kind in attribute specification"); - end if; - end Parse_Entity_Name_List; - - -- precond : ATTRIBUTE - -- postcond: next token - -- - -- [ 4.4 ] - -- attribute_declaration ::= ATTRIBUTE identifier : type_mark ; - -- - -- [ 5.1 ] - -- attribute_specification ::= - -- ATTRIBUTE attribute_designator OF entity_specification - -- IS expression ; - -- - -- entity_specification ::= entity_name_list : entity_class - -- - function Parse_Attribute return Iir - is - Ident : Name_Id; - Res : Iir; - Designator : Iir; - Loc, Start_Loc : Location_Type; - begin - Start_Loc := Get_Token_Location; - - -- Eat 'attribute'. - pragma Assert (Current_Token = Tok_Attribute); - Scan; - - Loc := Get_Token_Location; - if Current_Token = Tok_Identifier then - Ident := Current_Identifier; - - -- Skip identifier. - Scan; - else - Expect (Tok_Identifier); - Ident := Null_Identifier; - end if; - - case Current_Token is - when Tok_Colon => - Res := Create_Iir (Iir_Kind_Attribute_Declaration); - Set_Location (Res, Loc); - Set_Identifier (Res, Ident); - - -- Skip ':'. - Scan; - - Set_Type_Mark (Res, Parse_Type_Mark (Check_Paren => True)); - Scan_Semi_Colon_Declaration ("attribute declaration"); - - when Tok_Of => - Res := Create_Iir (Iir_Kind_Attribute_Specification); - Set_Location (Res, Loc); - Designator := Create_Iir (Iir_Kind_Simple_Name); - Set_Location (Designator, Loc); - Set_Identifier (Designator, Ident); - Set_Attribute_Designator (Res, Designator); - - -- Skip 'of'. - Scan; - - Parse_Entity_Name_List (Res); - - -- Skip 'is'. - Expect_Scan (Tok_Is); - - Set_Expression (Res, Parse_Expression); - Scan_Semi_Colon_Declaration ("attribute specification"); - - when others => - Error_Msg_Parse ("':' or 'of' expected after identifier"); - return Null_Iir; - end case; - - if Flag_Elocations then - Create_Elocations (Res); - Set_Start_Location (Res, Start_Loc); - end if; - - return Res; - end Parse_Attribute; - - -- precond : GROUP - -- postcond: ';' - -- - -- [ LRM93 4.6 ] - -- group_template_declaration ::= - -- GROUP identifier IS (entity_class_entry_list) ; - -- - -- entity_class_entry_list ::= entity_class_entry { , entity_class_entry } - -- - -- entity_class_entry ::= entity_class [ <> ] - function Parse_Group return Iir - is - Loc : Location_Type; - Ident : Name_Id; - begin - -- Skip 'group'. - pragma Assert (Current_Token = Tok_Group); - Scan; - - Loc := Get_Token_Location; - if Current_Token = Tok_Identifier then - Ident := Current_Identifier; - - -- Skip 'group'. - Scan; - else - Ident := Null_Identifier; - Expect (Tok_Identifier); - end if; - - case Current_Token is - when Tok_Is => - declare - use Iir_Chains.Entity_Class_Entry_Chain_Handling; - Res : Iir_Group_Template_Declaration; - El : Iir_Entity_Class; - Last : Iir_Entity_Class; - begin - Res := Create_Iir (Iir_Kind_Group_Template_Declaration); - Set_Location (Res, Loc); - Set_Identifier (Res, Ident); - - -- Skip 'is'. - Scan; - - -- Skip '('. - Expect_Scan (Tok_Left_Paren); - - Build_Init (Last); - loop - Append (Last, Res, Parse_Entity_Class_Entry); - if Current_Token = Tok_Box then - El := Create_Iir (Iir_Kind_Entity_Class); - Set_Location (El); - Set_Entity_Class (El, Tok_Box); - Append (Last, Res, El); - - -- Skip '<>'. - Scan; - - if Current_Token = Tok_Comma then - Error_Msg_Parse - ("'<>' is allowed only for the last " - & "entity class entry"); - end if; - end if; - exit when Current_Token /= Tok_Comma; - - -- Skip ','. - Scan; - end loop; - - -- Skip ')' ';' - Expect_Scan (Tok_Right_Paren); - Scan_Semi_Colon_Declaration ("group template"); - - return Res; - end; - when Tok_Colon => - declare - Res : Iir_Group_Declaration; - List : Iir_List; - begin - Res := Create_Iir (Iir_Kind_Group_Declaration); - Set_Location (Res, Loc); - Set_Identifier (Res, Ident); - - -- Skip ':'. - Scan; - - Set_Group_Template_Name - (Res, Parse_Name (Allow_Indexes => False)); - - -- Skip '('. - Expect_Scan (Tok_Left_Paren); - - List := Create_Iir_List; - loop - Append_Element (List, Parse_Name (Allow_Indexes => False)); - exit when Current_Token /= Tok_Comma; - - -- Skip ','. - Scan; - end loop; - - -- Skip ')' ';'. - Expect_Scan (Tok_Right_Paren); - Scan_Semi_Colon_Declaration ("group declaration"); - - Set_Group_Constituent_List (Res, List_To_Flist (List)); - return Res; - end; - when others => - Error_Msg_Parse ("':' or 'is' expected here"); - return Null_Iir; - end case; - end Parse_Group; - - -- precond : next token - -- postcond: ':' - -- - -- [ LRM93 5.4 ] - -- signal_list ::= signal_name { , signal_name } - -- | OTHERS - -- | ALL - function Parse_Signal_List return Iir_Flist - is - Res : Iir_List; - begin - case Current_Token is - when Tok_Others => - -- Skip 'others'. - Scan; - - return Iir_Flist_Others; - - when Tok_All => - -- Skip 'all'. - Scan; - - return Iir_Flist_All; - - when others => - Res := Create_Iir_List; - loop - Append_Element (Res, Parse_Name); - exit when Current_Token /= Tok_Comma; - - -- Skip ',' - Scan; - end loop; - - return List_To_Flist (Res); - end case; - end Parse_Signal_List; - - -- precond : DISCONNECT - -- postcond: next token. - -- - -- [ LRM93 5.4 ] - -- disconnection_specification ::= - -- DISCONNECT guarded_signal_specification AFTER time_expression ; - function Parse_Disconnection_Specification - return Iir_Disconnection_Specification - is - Res : Iir_Disconnection_Specification; - begin - pragma Assert (Current_Token = Tok_Disconnect); - - Res := Create_Iir (Iir_Kind_Disconnection_Specification); - Set_Location (Res); - - -- Skip 'disconnect' - Scan; - - Set_Signal_List (Res, Parse_Signal_List); - - -- Skip ':' - Expect_Scan (Tok_Colon); - - Set_Type_Mark (Res, Parse_Type_Mark (Check_Paren => True)); - - -- Skip 'after' - Expect_Scan (Tok_After); - - Set_Expression (Res, Parse_Expression); - - -- Skip ';'. - Scan_Semi_Colon_Declaration ("disconnection specification"); - - return Res; - end Parse_Disconnection_Specification; - - -- Parse PSL clock_declaration at 'clock'. - function Parse_Psl_Default_Clock_Cont (Loc : Location_Type) return Iir - is - Res : Iir; - begin - Res := Create_Iir (Iir_Kind_Psl_Default_Clock); - Set_Location (Res, Loc); - Xrefs.Xref_Keyword (Get_Token_Location); - - -- Recognize PSL keywords. - Vhdl.Scanner.Flag_Psl := True; - - -- Skip 'clock'. - Expect_Scan (Tok_Psl_Clock); - - -- Skip 'is'. - Expect_Scan (Tok_Is); - - Set_Psl_Boolean (Res, Parse_Psl.Parse_Psl_Boolean); - - Vhdl.Scanner.Flag_Scan_In_Comment := False; - Vhdl.Scanner.Flag_Psl := False; - - Expect_Scan (Tok_Semi_Colon); - - return Res; - end Parse_Psl_Default_Clock_Cont; - - -- 1850-2005 A.4.2 PSL declarations - -- clock_declaration ::= DEFAULT CLOCK IS clock_expression ; - function Parse_Psl_Default_Clock return Iir - is - Loc : Location_Type; - begin - Loc := Get_Token_Location; - - -- Recognize PSL keywords. - Vhdl.Scanner.Flag_Psl := True; - - -- Skip 'default'. - Scan; - - return Parse_Psl_Default_Clock_Cont (Loc); - end Parse_Psl_Default_Clock; - - function Parse_Psl_Declaration return Iir - is - Tok : constant Token_Type := Current_Token; - Loc : constant Location_Type := Get_Token_Location; - Res : Iir; - Decl : PSL_Node; - Id : Name_Id; - begin - -- Skip 'property', 'sequence' or 'endpoint'. - Scan; - - if Current_Token /= Tok_Identifier then - Error_Msg_Parse ("declaration name expected here"); - Id := Null_Identifier; - else - Id := Current_Identifier; - end if; - - -- Parse PSL declaration. - Vhdl.Scanner.Flag_Psl := True; - Decl := Parse_Psl.Parse_Psl_Declaration (Tok); - Vhdl.Scanner.Flag_Scan_In_Comment := False; - Vhdl.Scanner.Flag_Psl := False; - - Expect_Scan (Tok_Semi_Colon); - - if Tok = Tok_Psl_Endpoint - and then Parse_Psl.Is_Instantiated_Declaration (Decl) - then - -- Instantiated endpoint: make it visible from VHDL. - Res := Create_Iir (Iir_Kind_Psl_Endpoint_Declaration); - else - -- Otherwise, it will be visible only from PSL. - Res := Create_Iir (Iir_Kind_Psl_Declaration); - end if; - Set_Location (Res, Loc); - Set_Identifier (Res, Id); - Set_Psl_Declaration (Res, Decl); - - return Res; - end Parse_Psl_Declaration; - - -- Return the parent of a nested package. Used to check if some - -- declarations are allowed in a package. - function Get_Package_Parent (Decl : Iir) return Iir - is - Res : Iir; - Parent : Iir; - begin - Res := Decl; - loop - case Get_Kind (Res) is - when Iir_Kind_Package_Declaration - | Iir_Kind_Package_Body => - Parent := Get_Parent (Res); - if Get_Kind (Parent) = Iir_Kind_Design_Unit then - return Res; - else - Res := Parent; - end if; - when others => - return Res; - end case; - end loop; - end Get_Package_Parent; - - -- precond : next token - -- postcond: next token - -- - -- [ LRM08 3.2.3 Entity declarative part ] - -- entity_declarative_item ::= - -- subprogram_declaration - -- | subprogram_body - -- | subprogram_instantiation_declaration - -- | package_declaration - -- | package_body - -- | package_instantiation_declaration - -- | type_declaration - -- | subtype_declaration - -- | constant_declaration - -- | signal_declaration - -- | shared_variable_declaration - -- | file_declaration - -- | alias_declaration - -- | attribute_declaration - -- | attribute_specification - -- | disconnection_specification - -- | use_clause - -- | group_template_declaration - -- | group_declaration - -- | PSL_property_declaration - -- | PSL_sequence_declaration - -- | PSL_clock_declaration - -- - -- [ LRM08 3.3.2 Architecture declarative part ] - -- block_declarative_item ::= - -- subprogram_declaration - -- | subprogram_body - -- | subprogram_instantiation_declaration - -- | package_declaration - -- | package_body - -- | package_instantiation_declaration - -- | type_declaration - -- | subtype_declaration - -- | constant_declaration - -- | signal_declaration - -- | shared_variable_declaration - -- | file_declaration - -- | alias_declaration - -- | component_declaration - -- | attribute_declaration - -- | attribute_specification - -- | configuration_specification - -- | disconnection_specification - -- | use_clause - -- | group_template_declaration - -- | group_declaration - -- | PSL_property_declaration - -- | PSL_sequence_declaration - -- | PSL_clock_declaration - -- - -- [ LRM08 4.3 Subprogram bodies ] - -- subprogram_declarative_item ::= - -- subprogram_declaration - -- | subprogram_body - -- | subprogram_instantiation_declaration - -- | package_declaration - -- | package_body - -- | package_instantiation_declaration - -- | type_declaration - -- | subtype_declaration - -- | constant_declaration - -- | variable_declaration - -- | file_declaration - -- | alias_declaration - -- | attribute_declaration - -- | attribute_specification - -- | use_clause - -- | group_template_declaration - -- | group_declaration - -- - -- [ LRM08 4.7 Package declarations ] - -- package_declarative_item ::= - -- subprogram_declaration - -- | subprogram_instantiation_declaration - -- | package_declaration - -- | package_instantiation_declaration - -- | type_declaration - -- | subtype_declaration - -- | constant_declaration - -- | signal_declaration - -- | variable_declaration - -- | file_declaraton - -- | alias_declaration - -- | component_declaration - -- | attribute_declaration - -- | attribute_specification - -- | disconnection_specification - -- | use_clause - -- | group_template_declaration - -- | group_declaration - -- | PSL_property_declaration - -- | PSL_sequence_declaration - -- - -- [ LRM08 4.8 Package bodies ] - -- package_body_declarative_item ::= - -- subprogram_declaration - -- | subprogram_body - -- | subprogram_instantiation_declaration - -- | package_declaration - -- | package_body - -- | package_instantiation_declaration - -- | type_declaration - -- | subtype_declaration - -- | constant_declaration - -- | variable_declaration - -- | file_declaration - -- | alias_declaration - -- | attribute_declaration - -- | attribute_specification - -- | use_clause - -- | group_template_declaration - -- | group_declaration - -- - -- [ LRM08 5.6.2 Protected type declarations ] - -- protected_type_declarative_item ::= - -- subprogram_declaration - -- | subprogram_instantiation_declaration - -- | attribute_specification - -- | use_clause - -- - -- [ LRM08 5.6.3 Protected type bodies ] - -- protected_type_body_declarative_item ::= - -- subprogram_declaration - -- | subprogram_body - -- | subprogram_instantiation_declaration - -- | package_declaration - -- | package_body - -- | package_instantiation_declaration - -- | type_declaration - -- | subtype_declaration - -- | constant_declaration - -- | variable_declaration - -- | file_declaration - -- | alias_declaration - -- | attribute_declaration - -- | attribute_specification - -- | use_clause - -- | group_template_declaration - -- | group_declaration - -- - -- [ LRM08 11.3 Process statement ] - -- process_declarative_item ::= - -- subprogram_declaration - -- | subprogram_body - -- | subprogram_instantiation_declaration - -- | package_declaration - -- | package_body - -- | package_instantiation_declaration - -- | type_declaration - -- | subtype_declaration - -- | constant_declaration - -- | variable_declaration - -- | file_declaration - -- | alias_declaration - -- | attribute_declaration - -- | attribute_specification - -- | use_clause - -- | group_template_declaration - -- | group_declaration - -- - -- Some declarations are not allowed in every declarative part: - -- - subprogram_body, package_body: - -- not in package_declaration - -- - signal_declaration, disconnection_specification: - -- not in process, protected_type_body, package_body, subprogram - -- - variable_declaration: - -- shared in entity, block (*) - -- not shared in subprogram, protected_type_body, process - -- depends on parent for package and package_body - -- - component_declaration: - -- not in entity, subprogram, package_body, protected_type_body, - -- process - -- depends on parent for package - -- - configuration_specification: - -- not in entity, subprogram, package, package_body, protected_type_body, - -- process - -- - PSL_property_declaration, PSL_sequence_declaration: - -- in entity and block (*) - -- depends on parent for package - -- - PSL_clock_declaration: - -- in block (*) - -- - -- Declarations for protected_type_declaration are handled in sem. - -- - -- (*): block means block_declarative_item, ie: block_statement, - -- architecture_body and generate_statement) - procedure Parse_Declarative_Part (Parent : Iir) - is - use Declaration_Chain_Handling; - Last_Decl : Iir; - Decl : Iir; - Package_Parent_Cache : Iir; - - function Package_Parent return Iir is - begin - if Package_Parent_Cache = Null_Iir then - Package_Parent_Cache := Get_Package_Parent (Parent); - end if; - return Package_Parent_Cache; - end Package_Parent; - begin - Package_Parent_Cache := Null_Iir; - Build_Init (Last_Decl); - loop - Decl := Null_Iir; - case Current_Token is - when Tok_Invalid => - raise Internal_Error; - when Tok_Type => - Decl := Parse_Type_Declaration (Parent); - - -- LRM 2.5 Package declarations - -- If a package declarative item is a type declaration that is - -- a full type declaration whose type definition is a - -- protected_type definition, then that protected type - -- definition must not be a protected type body. - if Decl /= Null_Iir - and then Get_Kind (Decl) = Iir_Kind_Protected_Type_Body - then - case Get_Kind (Parent) is - when Iir_Kind_Package_Declaration => - Error_Msg_Parse (+Decl, "protected type body not " - & "allowed in package declaration"); - when others => - null; - end case; - end if; - when Tok_Subtype => - Decl := Parse_Subtype_Declaration (Parent); - when Tok_Nature => - Decl := Parse_Nature_Declaration; - when Tok_Terminal => - Decl := Parse_Terminal_Declaration (Parent); - when Tok_Quantity => - Decl := Parse_Quantity_Declaration (Parent); - when Tok_Signal => - -- LRM08 4.7 Package declarations - -- For package declaration that appears in a subprogram body, - -- a process statement, or a protected type body, [...] - -- Moreover, it is an eror if [...] a signal declaration [...] - -- appears as a package declarative item of such a package - -- declaration. - case Get_Kind (Package_Parent) is - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body => - Error_Msg_Parse - ("signal declaration not allowed in subprogram body"); - when Iir_Kinds_Process_Statement => - Error_Msg_Parse - ("signal declaration not allowed in process"); - when Iir_Kind_Protected_Type_Body - | Iir_Kind_Protected_Type_Declaration => - Error_Msg_Parse - ("signal declaration not allowed in protected type"); - when Iir_Kind_Package_Body => - Error_Msg_Parse - ("signal declaration not allowed in package body"); - when Iir_Kind_Entity_Declaration - | Iir_Kind_Architecture_Body - | Iir_Kind_Block_Statement - | Iir_Kind_Generate_Statement_Body - | Iir_Kind_Package_Declaration => - null; - when others => - Error_Kind ("parse_declarative_part", Package_Parent); - end case; - Decl := Parse_Object_Declaration (Parent); - when Tok_Constant => - Decl := Parse_Object_Declaration (Parent); - when Tok_Variable => - -- LRM93 4.3.1.3 Variable declarations - -- Variable declared immediatly within entity declarations, - -- architectures bodies, packages, packages bodies, and blocks - -- must be shared variable. - -- Variables declared immediatly within subprograms and - -- processes must not be shared variables. - -- Variables may appear in protected type bodies; such - -- variables, which must not be shared variables, represent - -- shared data. - case Get_Kind (Package_Parent) is - when Iir_Kind_Entity_Declaration - | Iir_Kind_Architecture_Body - | Iir_Kind_Block_Statement - | Iir_Kind_Generate_Statement_Body - | Iir_Kind_Package_Declaration - | Iir_Kind_Package_Body - | Iir_Kind_Protected_Type_Declaration => - -- FIXME: replace HERE with the kind of declaration - -- ie: "not allowed in a package" rather than "here". - Error_Msg_Parse - ("non-shared variable declaration not allowed here"); - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body - | Iir_Kinds_Process_Statement - | Iir_Kind_Protected_Type_Body => - null; - when others => - Error_Kind ("parse_declarative_part", Package_Parent); - end case; - Decl := Parse_Object_Declaration (Parent); - when Tok_Shared => - if Flags.Vhdl_Std <= Vhdl_87 then - Error_Msg_Parse ("shared variable not allowed in vhdl 87"); - end if; - -- LRM08 4.7 Package declarations - -- For package declaration that appears in a subprogram body, - -- a process statement, or a protected type body, it is an - -- error if a variable declaration in the package declaratie - -- part of the package declaration declares a shared variable. - - -- LRM08 4.8 Package bodies - -- For a package body that appears in a subprogram body, a - -- process statement or a protected type body, it is an error - -- if a variable declaration in the package body declarative - -- part of the package body declares a shared variable. - - -- LRM93 4.3.1.3 Variable declarations - -- Variable declared immediatly within entity declarations, - -- architectures bodies, packages, packages bodies, and blocks - -- must be shared variable. - -- Variables declared immediatly within subprograms and - -- processes must not be shared variables. - -- Variables may appear in proteted type bodies; such - -- variables, which must not be shared variables, represent - -- shared data. - case Get_Kind (Package_Parent) is - when Iir_Kind_Entity_Declaration - | Iir_Kind_Architecture_Body - | Iir_Kind_Block_Statement - | Iir_Kind_Generate_Statement_Body - | Iir_Kind_Package_Declaration - | Iir_Kind_Package_Body - | Iir_Kind_Protected_Type_Declaration => - null; - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body - | Iir_Kinds_Process_Statement - | Iir_Kind_Protected_Type_Body => - Error_Msg_Parse - ("shared variable declaration not allowed here"); - when others => - Error_Kind ("parse_declarative_part", Package_Parent); - end case; - Decl := Parse_Object_Declaration (Parent); - when Tok_File => - Decl := Parse_Object_Declaration (Parent); - when Tok_Function - | Tok_Procedure - | Tok_Pure - | Tok_Impure => - Decl := Parse_Subprogram_Declaration; - if Decl /= Null_Iir - and then Get_Subprogram_Body (Decl) /= Null_Iir - then - if Get_Kind (Parent) = Iir_Kind_Package_Declaration then - Error_Msg_Parse - (+Decl, "subprogram body not allowed in a package"); - end if; - end if; - when Tok_Alias => - Decl := Parse_Alias_Declaration; - when Tok_Component => - case Get_Kind (Parent) is - when Iir_Kind_Entity_Declaration - | Iir_Kind_Procedure_Body - | Iir_Kind_Function_Body - | Iir_Kinds_Process_Statement - | Iir_Kind_Package_Body - | Iir_Kind_Protected_Type_Body - | Iir_Kind_Protected_Type_Declaration => - Error_Msg_Parse - ("component declaration are not allowed here"); - when Iir_Kind_Architecture_Body - | Iir_Kind_Block_Statement - | Iir_Kind_Generate_Statement_Body - | Iir_Kind_Package_Declaration => - null; - when others => - Error_Kind ("parse_declarative_part", Package_Parent); - end case; - Decl := Parse_Component_Declaration; - when Tok_For => - case Get_Kind (Parent) is - when Iir_Kind_Entity_Declaration - | Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body - | Iir_Kinds_Process_Statement - | Iir_Kind_Package_Declaration - | Iir_Kind_Package_Body - | Iir_Kind_Protected_Type_Body - | Iir_Kind_Protected_Type_Declaration => - Error_Msg_Parse - ("configuration specification not allowed here"); - when Iir_Kind_Architecture_Body - | Iir_Kind_Block_Statement - | Iir_Kind_Generate_Statement_Body => - null; - when others => - Error_Kind ("parse_declarative_part", Package_Parent); - end case; - Decl := Parse_Configuration_Specification; - when Tok_Attribute => - Decl := Parse_Attribute; - when Tok_Disconnect => - -- LRM08 4.7 Package declarations - -- For package declaration that appears in a subprogram body, - -- a process statement, or a protected type body, [...] - -- Moreover, it is an eror if [...] a disconnection - -- specification [...] appears as a package declarative item - -- of such a package declaration. - case Get_Kind (Parent) is - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body - | Iir_Kinds_Process_Statement - | Iir_Kind_Protected_Type_Body - | Iir_Kind_Package_Body - | Iir_Kind_Protected_Type_Declaration => - Error_Msg_Parse - ("disconnect specification not allowed here"); - when Iir_Kind_Entity_Declaration - | Iir_Kind_Architecture_Body - | Iir_Kind_Block_Statement - | Iir_Kind_Generate_Statement_Body - | Iir_Kind_Package_Declaration => - null; - when others => - Error_Kind ("parse_declarative_part", Parent); - end case; - Decl := Parse_Disconnection_Specification; - when Tok_Use => - Decl := Parse_Use_Clause; - when Tok_Group => - Decl := Parse_Group; - when Tok_Package => - if Vhdl_Std < Vhdl_08 then - Error_Msg_Parse - ("nested package not allowed before vhdl 2008"); - end if; - Decl := Parse_Package (Parent); - if Decl /= Null_Iir - and then Get_Kind (Decl) = Iir_Kind_Package_Body - then - if Get_Kind (Parent) = Iir_Kind_Package_Declaration then - Error_Msg_Parse - (+Decl, "package body not allowed in a package"); - end if; - end if; - - if Current_Token = Tok_Semi_Colon then - -- Skip ';'. - Scan; - end if; - when Tok_Identifier => - if Vhdl_Std >= Vhdl_08 - and then Current_Identifier = Name_Default - then - -- This identifier is a PSL keyword. - Xrefs.Xref_Keyword (Get_Token_Location); - - -- Check whether default clock are allowed in this region. - case Get_Kind (Parent) is - when Iir_Kind_Function_Body - | Iir_Kind_Procedure_Body - | Iir_Kinds_Process_Statement - | Iir_Kind_Protected_Type_Body - | Iir_Kind_Package_Declaration - | Iir_Kind_Package_Body - | Iir_Kind_Protected_Type_Declaration => - Error_Msg_Parse - ("PSL default clock declaration not allowed here"); - when Iir_Kind_Entity_Declaration - | Iir_Kind_Architecture_Body - | Iir_Kind_Block_Statement - | Iir_Kind_Generate_Statement_Body => - null; - when others => - Error_Kind ("parse_declarative_part", Parent); - end case; - Decl := Parse_Psl_Default_Clock; - else - Error_Msg_Parse - ("object class keyword such as 'variable' is expected"); - Resync_To_End_Of_Declaration; - end if; - when Tok_Semi_Colon => - Error_Msg_Parse ("';' (semi colon) not allowed alone"); - Scan; - when others => - exit; - end case; - if Decl /= Null_Iir then - Append_Subchain (Last_Decl, Parent, Decl); - end if; - end loop; - end Parse_Declarative_Part; - - -- precond : ENTITY - -- postcond: next token. - -- - -- [ LRM93 1.1 ] - -- entity_declaration ::= - -- ENTITY identifier IS - -- entiy_header - -- entity_declarative_part - -- [ BEGIN - -- entity_statement_part ] - -- END [ ENTITY ] [ ENTITY_simple_name ] - -- - -- [ LRM93 1.1.1 ] - -- entity_header ::= - -- [ FORMAL_generic_clause ] - -- [ FORMAL_port_clause ] - procedure Parse_Entity_Declaration (Unit : Iir_Design_Unit) - is - Res: Iir_Entity_Declaration; - Start_Loc : Location_Type; - Begin_Loc : Location_Type; - End_Loc : Location_Type; - begin - Expect (Tok_Entity); - Res := Create_Iir (Iir_Kind_Entity_Declaration); - Start_Loc := Get_Token_Location; - - if Flag_Elocations then - Create_Elocations (Res); - Set_Start_Location (Res, Start_Loc); - end if; - - -- Skip 'entity'. - pragma Assert (Current_Token = Tok_Entity); - Scan; - - -- Get identifier. - Scan_Identifier (Res); - - -- Skip 'is'. - Expect_Scan (Tok_Is); - - Parse_Generic_Port_Clauses (Res); - - Parse_Declarative_Part (Res); - - if Current_Token = Tok_Begin then - Begin_Loc := Get_Token_Location; - Set_Has_Begin (Res, True); - - -- Skip 'begin'. - Scan; - - Parse_Concurrent_Statements (Res); - else - Begin_Loc := No_Location; - end if; - - -- end keyword is expected to finish an entity declaration - End_Loc := Get_Token_Location; - Expect_Scan (Tok_End); - - if Current_Token = Tok_Entity then - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse ("'entity' keyword not allowed here by vhdl 87"); - end if; - Set_End_Has_Reserved_Id (Res, True); - Scan; - end if; - Check_End_Name (Res); - Scan_Semi_Colon_Unit ("entity"); - - Set_Library_Unit (Unit, Res); - - if Flag_Elocations then - Set_Begin_Location (Res, Begin_Loc); - Set_End_Location (Res, End_Loc); - end if; - end Parse_Entity_Declaration; - - -- [ LRM93 7.3.2 ] - -- choice ::= simple_expression - -- | discrete_range - -- | ELEMENT_simple_name - -- | OTHERS - function Parse_A_Choice (Expr: Iir; Loc : Location_Type) return Iir - is - A_Choice: Iir; - Expr1: Iir; - begin - if Expr = Null_Iir then - if Current_Token = Tok_Others then - A_Choice := Create_Iir (Iir_Kind_Choice_By_Others); - Set_Location (A_Choice, Loc); - - -- Skip 'others' - Scan; - - return A_Choice; - else - Expr1 := Parse_Expression; - - if Expr1 = Null_Iir then - -- Handle parse error now. - -- FIXME: skip until '=>'. - A_Choice := Create_Iir (Iir_Kind_Choice_By_Expression); - Set_Location (A_Choice, Loc); - return A_Choice; - end if; - end if; - else - Expr1 := Expr; - end if; - - if Is_Range_Attribute_Name (Expr1) then - A_Choice := Create_Iir (Iir_Kind_Choice_By_Range); - Set_Choice_Range (A_Choice, Expr1); - elsif Current_Token = Tok_To or else Current_Token = Tok_Downto then - A_Choice := Create_Iir (Iir_Kind_Choice_By_Range); - Set_Choice_Range (A_Choice, Parse_Range_Expression (Expr1)); - else - A_Choice := Create_Iir (Iir_Kind_Choice_By_Expression); - Set_Choice_Expression (A_Choice, Expr1); - end if; - - Set_Location (A_Choice, Loc); - return A_Choice; - end Parse_A_Choice; - - -- [ LRM93 7.3.2 ] - -- choices ::= choice { | choice } - -- - -- Leave tok_double_arrow as current token. - procedure Parse_Choices (Expr: Iir; - First_Loc : Location_Type; - Chain : out Iir) - is - First, Last : Iir; - A_Choice: Iir; - Expr1 : Iir; - Loc : Location_Type; - begin - Sub_Chain_Init (First, Last); - Expr1 := Expr; - Loc := First_Loc; - loop - A_Choice := Parse_A_Choice (Expr1, Loc); - if First /= Null_Iir then - Set_Same_Alternative_Flag (A_Choice, True); - if Get_Kind (A_Choice) = Iir_Kind_Choice_By_Others then - Error_Msg_Parse ("'others' choice must be alone"); - end if; - end if; - - Sub_Chain_Append (First, Last, A_Choice); - - if Current_Token /= Tok_Bar then - Chain := First; - return; - end if; - Loc := Get_Token_Location; - - -- Skip '|'. - Scan; - - Expr1 := Null_Iir; - end loop; - end Parse_Choices; - - -- precond : '(' - -- postcond: next token - -- - -- This can be an expression or an aggregate. - -- - -- [ LRM93 7.3.2 ] - -- aggregate ::= ( element_association { , element_association } ) - -- - -- [ LRM93 7.3.2 ] - -- element_association ::= [ choices => ] expression - function Parse_Aggregate return Iir - is - use Iir_Chains.Association_Choices_Chain_Handling; - Expr: Iir; - Res: Iir; - Last : Iir; - Assoc: Iir; - Loc, Right_Loc : Location_Type; - begin - Loc := Get_Token_Location; - - -- Skip '(' - Scan; - - if Current_Token /= Tok_Others then - Expr := Parse_Expression; - case Current_Token is - when Tok_Comma - | Tok_Double_Arrow - | Tok_Bar => - -- This is really an aggregate - null; - when Tok_Right_Paren => - -- This was just a braced expression. - - Right_Loc := Get_Token_Location; - - -- Skip ')'. - Scan; - - if Expr /= Null_Iir - and then Get_Kind (Expr) = Iir_Kind_Aggregate - then - -- Parenthesis around aggregate is useless and change the - -- context for array aggregate. - Warning_Msg_Sem - (Warnid_Parenthesis, +Expr, - "suspicious parenthesis around aggregate"); - elsif not Flag_Parse_Parenthesis then - return Expr; - end if; - - -- Create a node for the parenthesis. - Res := Create_Iir (Iir_Kind_Parenthesis_Expression); - Set_Location (Res, Loc); - Set_Expression (Res, Expr); - - if Flag_Elocations then - Create_Elocations (Res); - Set_Right_Paren_Location (Res, Right_Loc); - end if; - - return Res; - - when Tok_Semi_Colon => - -- Surely a missing parenthesis. - -- FIXME: in case of multiple missing parenthesises, several - -- messages will be displayed - Error_Msg_Parse - ("missing ')' for opening parenthesis at %l", +Loc); - return Expr; - when others => - -- Surely a parse error... - null; - end case; - else - Expr := Null_Iir; - end if; - Res := Create_Iir (Iir_Kind_Aggregate); - Set_Location (Res, Loc); - Build_Init (Last); - loop - if Current_Token = Tok_Others then - Assoc := Parse_A_Choice (Null_Iir, Loc); - Expect (Tok_Double_Arrow); - - -- Eat '=>' - Scan; - - Expr := Parse_Expression; - else - -- Not others: an expression (or a range). - if Expr = Null_Iir then - Expr := Parse_Expression; - end if; - if Expr = Null_Iir then - return Null_Iir; - end if; - - case Current_Token is - when Tok_Comma - | Tok_Right_Paren => - Assoc := Create_Iir (Iir_Kind_Choice_By_None); - Set_Location (Assoc, Loc); - when others => - Parse_Choices (Expr, Loc, Assoc); - Expect (Tok_Double_Arrow); - - -- Eat '=>'. - Scan; - - Expr := Parse_Expression; - end case; - end if; - Set_Associated_Expr (Assoc, Expr); - Append_Subchain (Last, Res, Assoc); - exit when Current_Token /= Tok_Comma; - - Loc := Get_Token_Location; - - -- Eat ',' - Scan; - - Expr := Null_Iir; - end loop; - - -- Eat ')'. - Expect_Scan (Tok_Right_Paren); - return Res; - end Parse_Aggregate; - - -- precond : NEW - -- postcond: next token - -- - -- [LRM93 7.3.6] - -- allocator ::= NEW subtype_indication - -- | NEW qualified_expression - function Parse_Allocator return Iir - is - Loc: Location_Type; - Res : Iir; - Expr: Iir; - begin - Loc := Get_Token_Location; - - -- Accept 'new'. - Scan; - Expr := Parse_Name (Allow_Indexes => False); - if Expr /= Null_Iir - and then Get_Kind (Expr) /= Iir_Kind_Qualified_Expression - then - -- This is a subtype_indication. - Res := Create_Iir (Iir_Kind_Allocator_By_Subtype); - Expr := Parse_Subtype_Indication (Expr); - Set_Subtype_Indication (Res, Expr); - else - Res := Create_Iir (Iir_Kind_Allocator_By_Expression); - Set_Expression (Res, Expr); - end if; - - Set_Location (Res, Loc); - return Res; - end Parse_Allocator; - - -- precond : tok_bit_string - -- postcond: tok_bit_string - -- - -- Simply create the node for a bit string. - function Parse_Bit_String return Iir - is - Res : Iir; - B : Number_Base_Type; - begin - Res := Create_Iir (Iir_Kind_String_Literal8); - Set_Location (Res); - Set_String8_Id (Res, Current_String_Id); - Set_String_Length (Res, Current_String_Length); - case Get_Bit_String_Sign is - when 's' => - Set_Has_Sign (Res, True); - Set_Has_Signed (Res, True); - when 'u' => - Set_Has_Sign (Res, True); - Set_Has_Signed (Res, False); - when others => - Set_Has_Sign (Res, False); - Set_Has_Signed (Res, False); - end case; - - case Get_Bit_String_Base is - when 'b' => - B := Base_2; - when 'o' => - B := Base_8; - when 'd' => - B := Base_10; - when 'x' => - B := Base_16; - when others => - raise Internal_Error; - end case; - Set_Bit_String_Base (Res, B); - - return Res; - end Parse_Bit_String; - - -- Scan returns an expanded bit value. Adjust the expanded bit value as - -- required by the length. - procedure Resize_Bit_String (Lit : Iir; Nlen : Nat32) - is - use Str_Table; - - Old_Len : constant Nat32 := Get_String_Length (Lit); - Is_Signed : constant Boolean := Get_Has_Signed (Lit); - Id : constant String8_Id := Get_String8_Id (Lit); - C : Nat8; - begin - if Nlen > Old_Len then - -- Extend. - - -- LRM08 15.8 - -- -- If the length is greater than the number of characters in the - -- expanded bit value and the base specifier is B, UB, O, UO, X, - -- UX or D, the bit string value is obtained by concatenating a - -- string of 0 digits to the left of the expanded bit value. The - -- number of 0 digits in the string is such that the number of - -- characters in the result of the concatenation is the length of - -- the bit string literal. - -- - -- -- If the length is greater than the number of characters in the - -- expanded bit value and the base specifier is SB, SO or SX, the - -- bit string value is obtained by concatenating the the left of - -- the expanded bit value a string, each of whose characters is - -- the leftmost character of the expanded bit value. The number - -- of characters in the string is such that the number of - -- characters in the result of the concatenation is the length of - -- the bit string literal. - if Is_Signed then - if Old_Len = 0 then - Error_Msg_Parse - (+Lit, "cannot expand an empty signed bit string"); - C := Character'Pos ('0'); - else - C := Element_String8 (Id, 1); - end if; - else - C := Character'Pos ('0'); - end if; - Resize_String8 (Nlen); - -- Shift (position 1 is the MSB). - for I in reverse 1 .. Old_Len loop - Set_Element_String8 (Id, I + Nlen - Old_Len, - Element_String8 (Id, I)); - end loop; - for I in 1 .. Nlen - Old_Len loop - Set_Element_String8 (Id, I, C); - end loop; - Set_String_Length (Lit, Nlen); - - elsif Nlen < Old_Len then - -- Reduce. - - -- LRM08 15.8 - -- -- If the length is less than the number of characters in the - -- expanded bit value and the base specifier is B, UB, O, UO, X, - -- UX or D, the bit string value is obtained by deleting - -- sufficient characters from the left of the expanded bit value - -- to yield a string whose length is the length of the bit string - -- literal. It is an error if any of the character so deleted is - -- other than the digit 0. - -- - -- -- If the length is less than the number of characters in the - -- expanded bit value and the base specifier is SB, SO or SX, the - -- bit string value is obtained by deleting sufficient characters - -- from the left of the expanded bit value to yield a string whose - -- length is the length of the bit string literal. It is an error - -- if any of the characters so deleted differs from the leftmost - -- remaining character. - if Is_Signed then - C := Element_String8 (Id, 1 + Old_Len - Nlen); - else - C := Character'Pos ('0'); - end if; - for I in 1 .. Old_Len - Nlen loop - if Element_String8 (Id, I) /= C then - Error_Msg_Parse - (+Lit, "truncation of bit string changes the value"); - -- Avoid error storm. - exit; - end if; - end loop; - -- Shift (position 1 is the MSB). - for I in 1 .. Nlen loop - Set_Element_String8 (Id, I, - Element_String8 (Id, I + Old_Len - Nlen)); - end loop; - Resize_String8 (Nlen); - Set_String_Length (Lit, Nlen); - - else - -- LRM08 15.8 - -- -- If the length is equal to the number of characters in the - -- expanded bit value, the string literal value is the expanded - -- bit value itself. - null; - end if; - end Resize_Bit_String; - - -- Precond : next token after tok_integer - -- postcond: likewise - -- - -- Return an integer_literal or a physical_literal. - function Parse_Integer_Literal (Val : Iir_Int64) return Iir - is - Res : Iir; - begin - if Current_Token = Tok_Identifier then - -- physical literal - Res := Create_Iir (Iir_Kind_Physical_Int_Literal); - Set_Unit_Name (Res, Parse_Name (Allow_Indexes => False)); - else - -- integer literal - Res := Create_Iir (Iir_Kind_Integer_Literal); - end if; - Set_Value (Res, Val); - return Res; - end Parse_Integer_Literal; - - -- precond : next token - -- postcond: next token - -- - -- [ LRM93 7.1 ] - -- primary ::= name - -- | literal - -- | aggregate - -- | function_call - -- | qualified_expression - -- | type_conversion - -- | allocator - -- | ( expression ) - -- - -- [ LRM93 7.3.1 ] - -- literal ::= numeric_literal - -- | enumeration_literal - -- | string_literal - -- | bit_string_literal - -- | NULL - -- - -- [ LRM93 7.3.1 ] - -- numeric_literal ::= abstract_literal - -- | physical_literal - -- - -- [ LRM93 13.4 ] - -- abstract_literal ::= decimal_literal | based_literal - -- - -- [ LRM93 3.1.3 ] - -- physical_literal ::= [ abstract_literal ] UNIT_name - function Parse_Primary return Iir_Expression - is - Res: Iir_Expression; - Int: Iir_Int64; - Fp: Iir_Fp64; - Loc: Location_Type; - begin - case Current_Token is - when Tok_Integer => - Int := Current_Iir_Int64; - Loc := Get_Token_Location; - - -- Skip integer - Scan; - - Res := Parse_Integer_Literal (Int); - Set_Location (Res, Loc); - return Res; - - when Tok_Real => - Fp := Current_Iir_Fp64; - Loc := Get_Token_Location; - - -- Skip real - Scan; - - if Current_Token = Tok_Identifier then - -- physical literal - Res := Create_Iir (Iir_Kind_Physical_Fp_Literal); - Set_Unit_Name (Res, Parse_Name (Allow_Indexes => False)); - else - -- real literal - Res := Create_Iir (Iir_Kind_Floating_Point_Literal); - end if; - Set_Location (Res, Loc); - Set_Fp_Value (Res, Fp); - return Res; - - when Tok_Identifier - | Tok_Double_Less => - Res := Parse_Name (Allow_Indexes => True); - if Res /= Null_Iir - and then Get_Kind (Res) = Iir_Kind_Signature then - Error_Msg_Parse (+Res, "signature not allowed in expression"); - return Get_Signature_Prefix (Res); - else - return Res; - end if; - - when Tok_Character => - Res := Current_Text; - Scan; - if Current_Token = Tok_Tick then - Error_Msg_Parse - ("prefix of an attribute can't be a character literal"); - -- skip tick. - Scan; - -- skip attribute designator - Scan; - end if; - return Res; - when Tok_Left_Paren => - if Parenthesis_Depth = Max_Parenthesis_Depth then - Error_Msg_Parse - ("too many open parenthesis, skip to the matching one"); - Skip_Until_Closing_Parenthesis; - return Null_Iir; - else - Parenthesis_Depth := Parenthesis_Depth + 1; - Res := Parse_Aggregate; - Parenthesis_Depth := Parenthesis_Depth - 1; - return Res; - end if; - when Tok_String => - return Parse_Name; - when Tok_Null => - Res := Create_Iir (Iir_Kind_Null_Literal); - Set_Location (Res); - Scan; - return Res; - when Tok_New => - return Parse_Allocator; - - when Tok_Integer_Letter => - Int := Current_Iir_Int64; - Loc := Get_Token_Location; - - -- Skip integer - Scan; - - if Current_Token = Tok_Bit_String then - Res := Parse_Bit_String; - Set_Has_Length (Res, True); - - -- Skip bit string - Scan; - - -- Resize. - Resize_Bit_String (Res, Nat32 (Int)); - else - Error_Msg_Parse - (Get_Token_Location, - "space is required between number and unit name"); - Res := Parse_Integer_Literal (Int); - end if; - Set_Location (Res, Loc); - return Res; - - when Tok_Bit_String => - Res := Parse_Bit_String; - - -- Skip bit string - Scan; - - return Res; - - when Tok_Minus - | Tok_Plus => - Error_Msg_Parse - ("'-' and '+' are not allowed in primary, use parenthesis"); - return Parse_Expression (Prio_Simple); - - when Tok_Comma - | Tok_Semi_Colon - | Tok_Right_Paren - | Tok_Eof - | Tok_End => - -- Token not to be skipped - Error_Msg_Parse ("primary expression expected"); - return Create_Error_Node; - - when others => - Unexpected ("primary"); - return Create_Error_Node; - end case; - end Parse_Primary; - - -- [ LRM08 9 Expressions ] - -- - -- expression ::= - -- condition_operator primary - -- | logical_expression - -- - -- logical_expression ::= - -- relation { and relation } - -- | relation { or relation } - -- | relation { xor relation } - -- | relation [ nand relation ] - -- | relation [ nor relation ] - -- | relation { xnor relation } - -- - -- relation ::= - -- shift_expression [ relational_operator shift_expression ] - -- - -- shift_expression ::= - -- simple_expression [ shift_operator simple_expression ] - -- - -- simple_expression ::= - -- [ sign ] term { adding_operator term } - -- - -- term ::= - -- factor { multiplying_operator factor } - -- - -- factor ::= - -- primary [ ** primary ] - -- | abs primary - -- | not primary - -- | logical_operator primary - function Build_Unary_Factor (Op : Iir_Kind) return Iir - is - Res : Iir; - begin - Res := Create_Iir (Op); - Set_Location (Res); - - -- Skip operator. - Scan; - - Set_Operand (Res, Parse_Primary); - - return Res; - end Build_Unary_Factor; - - function Build_Unary_Simple (Op : Iir_Kind) return Iir - is - Res : Iir; - begin - Res := Create_Iir (Op); - Set_Location (Res); - - -- Skip operator. - Scan; - - Set_Operand (Res, Parse_Expression (Prio_Term)); - - return Res; - end Build_Unary_Simple; - - function Build_Unary_Factor_08 (Op : Iir_Kind) return Iir is - begin - if Flags.Vhdl_Std < Vhdl_08 then - Error_Msg_Parse ("missing left operand of logical expression"); - - -- Skip operator - Scan; - - return Parse_Primary; - else - return Build_Unary_Factor (Op); - end if; - end Build_Unary_Factor_08; - - function Parse_Unary_Expression return Iir - is - Res, Left : Iir_Expression; - begin - case Current_Token is - when Tok_Plus => - return Build_Unary_Simple (Iir_Kind_Identity_Operator); - when Tok_Minus => - return Build_Unary_Simple (Iir_Kind_Negation_Operator); - - when Tok_Abs => - return Build_Unary_Factor (Iir_Kind_Absolute_Operator); - when Tok_Not => - return Build_Unary_Factor (Iir_Kind_Not_Operator); - - when Tok_And => - return Build_Unary_Factor_08 (Iir_Kind_Reduction_And_Operator); - when Tok_Or => - return Build_Unary_Factor_08 (Iir_Kind_Reduction_Or_Operator); - when Tok_Nand => - return Build_Unary_Factor_08 (Iir_Kind_Reduction_Nand_Operator); - when Tok_Nor => - return Build_Unary_Factor_08 (Iir_Kind_Reduction_Nor_Operator); - when Tok_Xor => - return Build_Unary_Factor_08 (Iir_Kind_Reduction_Xor_Operator); - when Tok_Xnor => - return Build_Unary_Factor_08 (Iir_Kind_Reduction_Xnor_Operator); - - when others => - Left := Parse_Primary; - if Current_Token = Tok_Double_Star then - Res := Create_Iir (Iir_Kind_Exponentiation_Operator); - Set_Location (Res); - - -- Skip '**'. - Scan; - - Set_Left (Res, Left); - Set_Right (Res, Parse_Primary); - return Res; - else - return Left; - end if; - end case; - end Parse_Unary_Expression; - - -- Example: When PRIO is Prio_Simple, a simple expression will be returned. - function Parse_Binary_Expression (Left : Iir; Prio : Prio_Type) return Iir - is - Res : Iir; - Expr : Iir; - Op : Iir_Kind; - Op_Prio : Prio_Type; - Op_Tok : Token_Type; - begin - Res := Left; - loop - Op_Tok := Current_Token; - case Op_Tok is - when Tok_Star => - Op := Iir_Kind_Multiplication_Operator; - Op_Prio := Prio_Term; - when Tok_Slash => - Op := Iir_Kind_Division_Operator; - Op_Prio := Prio_Term; - when Tok_Mod => - Op := Iir_Kind_Modulus_Operator; - Op_Prio := Prio_Term; - when Tok_Rem => - Op := Iir_Kind_Remainder_Operator; - Op_Prio := Prio_Term; - - when Tok_Plus => - Op := Iir_Kind_Addition_Operator; - Op_Prio := Prio_Simple; - when Tok_Minus => - Op := Iir_Kind_Substraction_Operator; - Op_Prio := Prio_Simple; - when Tok_Ampersand => - Op := Iir_Kind_Concatenation_Operator; - Op_Prio := Prio_Simple; - - when Tok_Sll => - Op := Iir_Kind_Sll_Operator; - Op_Prio := Prio_Shift; - when Tok_Sla => - Op := Iir_Kind_Sla_Operator; - Op_Prio := Prio_Shift; - when Tok_Srl => - Op := Iir_Kind_Srl_Operator; - Op_Prio := Prio_Shift; - when Tok_Sra => - Op := Iir_Kind_Sra_Operator; - Op_Prio := Prio_Shift; - when Tok_Rol => - Op := Iir_Kind_Rol_Operator; - Op_Prio := Prio_Shift; - when Tok_Ror => - Op := Iir_Kind_Ror_Operator; - Op_Prio := Prio_Shift; - - when Tok_Equal => - Op := Iir_Kind_Equality_Operator; - Op_Prio := Prio_Relation; - when Tok_Not_Equal => - Op := Iir_Kind_Inequality_Operator; - Op_Prio := Prio_Relation; - when Tok_Less => - Op := Iir_Kind_Less_Than_Operator; - Op_Prio := Prio_Relation; - when Tok_Less_Equal => - Op := Iir_Kind_Less_Than_Or_Equal_Operator; - Op_Prio := Prio_Relation; - when Tok_Greater => - Op := Iir_Kind_Greater_Than_Operator; - Op_Prio := Prio_Relation; - when Tok_Greater_Equal => - Op := Iir_Kind_Greater_Than_Or_Equal_Operator; - Op_Prio := Prio_Relation; - when Tok_Match_Equal => - Op := Iir_Kind_Match_Equality_Operator; - Op_Prio := Prio_Relation; - when Tok_Match_Not_Equal => - Op := Iir_Kind_Match_Inequality_Operator; - Op_Prio := Prio_Relation; - when Tok_Match_Less => - Op := Iir_Kind_Match_Less_Than_Operator; - Op_Prio := Prio_Relation; - when Tok_Match_Less_Equal => - Op := Iir_Kind_Match_Less_Than_Or_Equal_Operator; - Op_Prio := Prio_Relation; - when Tok_Match_Greater => - Op := Iir_Kind_Match_Greater_Than_Operator; - Op_Prio := Prio_Relation; - when Tok_Match_Greater_Equal => - Op := Iir_Kind_Match_Greater_Than_Or_Equal_Operator; - Op_Prio := Prio_Relation; - - when Tok_And => - Op := Iir_Kind_And_Operator; - Op_Prio := Prio_Logical; - when Tok_Or => - Op := Iir_Kind_Or_Operator; - Op_Prio := Prio_Logical; - when Tok_Xor => - Op := Iir_Kind_Xor_Operator; - Op_Prio := Prio_Logical; - when Tok_Nand => - Op := Iir_Kind_Nand_Operator; - Op_Prio := Prio_Logical; - when Tok_Nor => - Op := Iir_Kind_Nor_Operator; - Op_Prio := Prio_Logical; - when Tok_Xnor => - Op := Iir_Kind_Xnor_Operator; - Op_Prio := Prio_Logical; - - when others => - return Res; - end case; - - -- If the OP_PRIO is less than PRIO, the binary operator will apply - -- to the whole expression. - -- eg: A * B + C - if Op_Prio < Prio then - return Res; - end if; - - Expr := Create_Iir (Op); - Set_Location (Expr); - Set_Left (Expr, Res); - - -- Skip operator. - Scan; - - -- Catch errors for Ada programmers. - if Current_Token = Tok_Then or Current_Token = Tok_Else then - Error_Msg_Parse ("""or else"" and ""and then"" sequences " - & "are not allowed in vhdl", Cont => True); - Error_Msg_Parse ("""and"" and ""or"" are short-circuit " - & "operators for BIT and BOOLEAN types"); - Scan; - end if; - - if Op_Prio >= Prio_Simple and then Current_Token in Token_Sign_Type - then - Error_Msg_Parse ("'-'/'+' can only appear before the first term"); - end if; - - -- Left association: A + B + C is (A + B) + C - Set_Right (Expr, Parse_Expression (Prio_Type'Succ (Op_Prio))); - Res := Expr; - - -- Only one relational_operator or shift_operator. - if Op_Prio = Prio_Relation then - if Current_Token in Token_Relational_Operator_Type then - Error_Msg_Parse - ("use parenthesis for consecutive relational expressions"); - end if; - elsif Op_Prio = Prio_Shift then - -- Only one shift_operator. - if Current_Token in Token_Shift_Operator_Type then - Error_Msg_Parse - ("use parenthesis for consecutive shift expressions"); - end if; - elsif Op_Prio = Prio_Logical then - if Current_Token = Op_Tok then - if Op_Tok = Tok_Nand or Op_Tok = Tok_Nor then - Error_Msg_Parse - ("sequence of 'nor' or 'nand' not allowed", Cont => True); - Error_Msg_Parse - ("('nor' and 'nand' are not associative)"); - end if; - elsif Current_Token in Token_Logical_Type then - -- Expression is a sequence of relations, with the same - -- operator. - Error_Msg_Parse ("only one type of logical operators may be " - & "used to combine relation"); - end if; - end if; - end loop; - end Parse_Binary_Expression; - - function Parse_Expression (Prio : Prio_Type := Prio_Expression) return Iir - is - Left : Iir; - Res : Iir; - begin - if Current_Token = Tok_Condition then - if Prio /= Prio_Expression then - Error_Msg_Parse - ("'??' must be the first operator of an expression"); - end if; - Res := Create_Iir (Iir_Kind_Condition_Operator); - Set_Location (Res); - - -- Skip '??' - Scan; - - Set_Operand (Res, Parse_Primary); - else - Left := Parse_Unary_Expression; - Res := Parse_Binary_Expression (Left, Prio); - end if; - - return Res; - end Parse_Expression; - - -- precond : next token - -- postcond: next token. - -- - -- [ 8.4 ] - -- waveform ::= waveform_element { , waveform_element } - -- | UNAFFECTED - -- - -- [ 8.4.1 ] - -- waveform_element ::= VALUE_expression [ AFTER TIME_expression ] - -- | NULL [ AFTER TIME_expression ] - function Parse_Waveform return Iir_Waveform_Element - is - Res: Iir_Waveform_Element; - We, Last_We : Iir_Waveform_Element; - begin - if Current_Token = Tok_Unaffected then - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse ("'unaffected' is not allowed in vhdl87"); - end if; - - Res := Create_Iir (Iir_Kind_Unaffected_Waveform); - Set_Location (Res); - - -- Skip 'unaffected'. - Scan; - else - Sub_Chain_Init (Res, Last_We); - loop - We := Create_Iir (Iir_Kind_Waveform_Element); - Sub_Chain_Append (Res, Last_We, We); - Set_Location (We); - - -- Note: NULL is handled as a null_literal. - Set_We_Value (We, Parse_Expression); - - if Current_Token = Tok_After then - -- Skip 'after'. - Scan; - - Set_Time (We, Parse_Expression); - end if; - - exit when Current_Token /= Tok_Comma; - - -- Skip ','. - Scan; - end loop; - end if; - - return Res; - end Parse_Waveform; - - -- precond : next token - -- postcond: next token - -- - -- [ 8.4 ] - -- delay_mechanism ::= TRANSPORT - -- | [ REJECT TIME_expression ] INERTIAL - procedure Parse_Delay_Mechanism (Assign: Iir) is - begin - if Current_Token = Tok_Transport then - Set_Delay_Mechanism (Assign, Iir_Transport_Delay); - Scan; - else - Set_Delay_Mechanism (Assign, Iir_Inertial_Delay); - if Current_Token = Tok_Reject then - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse - ("'reject' delay mechanism not allowed in vhdl 87"); - end if; - Scan; - Set_Reject_Time_Expression (Assign, Parse_Expression); - Expect (Tok_Inertial); - Scan; - elsif Current_Token = Tok_Inertial then - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse - ("'inertial' keyword not allowed in vhdl 87"); - end if; - Scan; - end if; - end if; - end Parse_Delay_Mechanism; - - -- precond : next token - -- postcond: next token - -- - -- [ LRM93 9.5 ] - -- options ::= [ GUARDED ] [ delay_mechanism ] - procedure Parse_Options (Stmt : Iir) is - begin - if Current_Token = Tok_Guarded then - Set_Guard (Stmt, Stmt); - Scan; - end if; - Parse_Delay_Mechanism (Stmt); - end Parse_Options; - - -- precond : next tkoen - -- postcond: next token (';') - -- - -- [ LRM93 9.5.1 ] - -- conditional_waveforms ::= - -- { waveform WHEN condition ELSE } - -- waveform [ WHEN condition ] - function Parse_Conditional_Waveforms return Iir - is - Wf : Iir; - Res : Iir; - Cond_Wf, N_Cond_Wf : Iir_Conditional_Waveform; - begin - Wf := Parse_Waveform; - if Current_Token /= Tok_When then - return Wf; - else - Res := Create_Iir (Iir_Kind_Conditional_Waveform); - Set_Location (Res); - Set_Waveform_Chain (Res, Wf); - - Cond_Wf := Res; - loop - -- Skip 'when'. - Scan; - - Set_Condition (Cond_Wf, Parse_Expression); - - if Current_Token /= Tok_Else then - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse ("else missing in vhdl 87"); - end if; - exit; - end if; - - N_Cond_Wf := Create_Iir (Iir_Kind_Conditional_Waveform); - Set_Location (N_Cond_Wf); - Set_Chain (Cond_Wf, N_Cond_Wf); - Cond_Wf := N_Cond_Wf; - - -- Eat 'else' - Scan; - - Set_Waveform_Chain (Cond_Wf, Parse_Waveform); - - exit when Current_Token /= Tok_When; - end loop; - return Res; - end if; - end Parse_Conditional_Waveforms; - - -- precond : '<=' (or ':=') - -- postcond: next token (after ';') - -- - -- [ LRM93 9.5.1 ] - -- concurrent_conditional_signal_assignment ::= - -- target <= [ GUARDED ] [ delay_mechanism ] conditional_waveforms ; - -- - -- [ LRM08 10.5.2.1 ] - -- concurrent_simple_waveform_assignment ::= - -- target <= [ GUARDED ] [ delay_mechanism ] waveform ; - function Parse_Concurrent_Conditional_Signal_Assignment (Target: Iir) - return Iir - is - Res: Iir; - Loc : Location_Type; - N_Res : Iir; - Wf : Iir; - begin - Loc := Get_Token_Location; - case Current_Token is - when Tok_Less_Equal => - -- Skip '<='. - Scan; - when Tok_Assign => - Error_Msg_Parse ("':=' not allowed in concurrent statement, " - & "replaced by '<='"); - -- Skip ':='. - Scan; - when others => - Expect (Tok_Less_Equal); - end case; - - -- Assume simple signal assignment. - Res := Create_Iir (Iir_Kind_Concurrent_Simple_Signal_Assignment); - Parse_Options (Res); - - Wf := Parse_Conditional_Waveforms; - if Wf /= Null_Iir - and then Get_Kind (Wf) = Iir_Kind_Conditional_Waveform - then - N_Res := - Create_Iir (Iir_Kind_Concurrent_Conditional_Signal_Assignment); - if Get_Guard (Res) /= Null_Iir then - Set_Guard (N_Res, N_Res); - end if; - Set_Delay_Mechanism (N_Res, Get_Delay_Mechanism (Res)); - Set_Reject_Time_Expression (N_Res, Get_Reject_Time_Expression (Res)); - Free_Iir (Res); - Res := N_Res; - Set_Conditional_Waveform_Chain (Res, Wf); - else - Set_Waveform_Chain (Res, Wf); - end if; - Set_Location (Res, Loc); - Set_Target (Res, Target); - Expect_Scan (Tok_Semi_Colon, "';' expected at end of signal assignment"); - - return Res; - end Parse_Concurrent_Conditional_Signal_Assignment; - - -- precond : WITH - -- postcond: next token - -- - -- [ LRM93 9.5.2 ] - -- selected_signal_assignment ::= - -- WITH expresion SELECT - -- target <= options selected_waveforms ; - -- - -- [ LRM93 9.5.2 ] - -- selected_waveforms ::= - -- { waveform WHEN choices , } - -- waveform WHEN choices - function Parse_Selected_Signal_Assignment return Iir - is - use Iir_Chains.Selected_Waveform_Chain_Handling; - Res : Iir; - Assoc : Iir; - Wf_Chain : Iir_Waveform_Element; - Target : Iir; - Last : Iir; - When_Loc : Location_Type; - begin - -- Skip 'with'. - Scan; - - Res := Create_Iir (Iir_Kind_Concurrent_Selected_Signal_Assignment); - Set_Location (Res); - Set_Expression (Res, Parse_Expression); - - Expect_Scan (Tok_Select, "'select' expected after expression"); - - if Current_Token = Tok_Left_Paren then - Target := Parse_Aggregate; - else - Target := Parse_Name (Allow_Indexes => True); - end if; - Set_Target (Res, Target); - Expect_Scan (Tok_Less_Equal); - - Parse_Options (Res); - - Build_Init (Last); - loop - Wf_Chain := Parse_Waveform; - Expect (Tok_When, "'when' expected after waveform"); - When_Loc := Get_Token_Location; - - -- Eat 'when'. - Scan; - - Parse_Choices (Null_Iir, When_Loc, Assoc); - Set_Associated_Chain (Assoc, Wf_Chain); - Append_Subchain (Last, Res, Assoc); - exit when Current_Token /= Tok_Comma; - -- Skip ','. - Scan; - end loop; - - Expect_Scan (Tok_Semi_Colon, "';' expected at end of signal assignment"); - - return Res; - end Parse_Selected_Signal_Assignment; - - -- precond : next token - -- postcond: next token. - -- - -- [ LRM93 8.1 ] - -- sensitivity_list ::= SIGNAL_name { , SIGNAL_name } - procedure Parse_Sensitivity_List (List: Iir_List) - is - El : Iir; - begin - loop - El := Parse_Name (Allow_Indexes => True); - if El /= Null_Iir then - case Get_Kind (El) is - when Iir_Kind_Simple_Name - | Iir_Kind_Parenthesis_Name - | Iir_Kind_Selected_Name - | Iir_Kind_Slice_Name - | Iir_Kind_Attribute_Name - | Iir_Kind_Selected_By_All_Name - | Iir_Kind_Indexed_Name => - null; - when others => - Error_Msg_Parse - ("only names are allowed in a sensitivity list"); - El := Create_Error_Node (El); - end case; - Append_Element (List, El); - end if; - - exit when Current_Token /= Tok_Comma; - - -- Skip ','. - Scan; - end loop; - end Parse_Sensitivity_List; - - -- precond : ASSERT - -- postcond: next token - -- Note: this fill an sequential or a concurrent statement. - -- - -- [ LRM93 9.4 ] - -- concurrent_assertion_statement ::= - -- [ label : ] [ POSTPONED ] assertion ; - -- - -- [ LRM93 8.2 ] - -- assertion ::= ASSERT condition - -- [ REPORT expression ] [ SEVERITY expression ] - procedure Parse_Assertion (Stmt: Iir) is - begin - Set_Location (Stmt); - - -- Skip 'assert'. - Scan; - - Set_Assertion_Condition (Stmt, Parse_Expression); - - if Current_Token = Tok_Report then - -- Skip 'report'. - Scan; - - Set_Report_Expression (Stmt, Parse_Expression); - end if; - - if Current_Token = Tok_Severity then - -- Skip 'severity'. - Scan; - - Set_Severity_Expression (Stmt, Parse_Expression); - if Current_Token = Tok_Report then - -- Nice message in case of inversion. - Error_Msg_Parse - ("report expression must precede severity expression"); - Scan; - Set_Report_Expression (Stmt, Parse_Expression); - end if; - end if; - end Parse_Assertion; - - -- precond : REPORT - -- postcond: next token - -- - -- [ 8.3 ] - -- report_statement ::= REPORT expression [ SEVERITY expression ] - function Parse_Report_Statement return Iir_Report_Statement - is - Res : Iir_Report_Statement; - begin - Res := Create_Iir (Iir_Kind_Report_Statement); - Set_Location (Res); - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse ("report statement not allowed in vhdl87"); - end if; - - -- Skip 'report'. - Scan; - - Set_Report_Expression (Res, Parse_Expression); - - if Current_Token = Tok_Severity then - -- Skip 'severity'. - Scan; - - Set_Severity_Expression (Res, Parse_Expression); - end if; - return Res; - end Parse_Report_Statement; - - -- precond : WAIT - -- postcond: ';' - -- - -- [ LRM93 8.1 ] - -- wait_statement ::= - -- [ label : ] WAIT [ sensitivity_clause ] [ condition_clause ] - -- [ timeout_clause ] ; - -- - -- [ LRM93 8.1 ] - -- sensitivity_clause ::= ON sensitivity_list - -- - -- [ LRM93 8.1 ] - -- condition_clause ::= UNTIL conditiion - -- - -- [ LRM93 8.1 ] - -- timeout_clause ::= FOR TIME_expression - function Parse_Wait_Statement return Iir_Wait_Statement - is - Res: Iir_Wait_Statement; - List: Iir_List; - begin - Res := Create_Iir (Iir_Kind_Wait_Statement); - Set_Location (Res); - - -- Skip 'wait'. - Scan; - - -- Sensitivity clause. - case Current_Token is - when Tok_On => - List := Create_Iir_List; - Set_Sensitivity_List (Res, List); - Scan; - Parse_Sensitivity_List (List); - when Tok_Until => - null; - when Tok_For => - null; - when Tok_Semi_Colon => - return Res; - when others => - Error_Msg_Parse ("'on', 'until', 'for' or ';' expected"); - Resync_To_End_Of_Statement; - return Res; - end case; - - -- Condition clause. - case Current_Token is - when Tok_On => - Error_Msg_Parse ("only one sensitivity is allowed"); - Resync_To_End_Of_Statement; - return Res; - when Tok_Until => - Scan; - Set_Condition_Clause (Res, Parse_Expression); - when Tok_For => - null; - when Tok_Semi_Colon => - return Res; - when others => - Error_Msg_Parse ("'until', 'for' or ';' expected"); - Resync_To_End_Of_Statement; - return Res; - end case; - - -- Timeout clause. - case Current_Token is - when Tok_On => - Error_Msg_Parse ("only one sensitivity clause is allowed"); - Resync_To_End_Of_Statement; - return Res; - when Tok_Until => - Error_Msg_Parse ("only one condition clause is allowed"); - Resync_To_End_Of_Statement; - return Res; - when Tok_For => - Scan; - Set_Timeout_Clause (Res, Parse_Expression); - return Res; - when Tok_Semi_Colon => - return Res; - when others => - Error_Msg_Parse ("'for' or ';' expected"); - Resync_To_End_Of_Statement; - return Res; - end case; - end Parse_Wait_Statement; - - -- precond : IF - -- postcond: next token. - -- - -- [ LRM93 8.7 ] - -- if_statement ::= - -- [ IF_label : ] - -- IF condition THEN - -- sequence_of_statements - -- { ELSIF condition THEN - -- sequence_of_statements } - -- [ ELSE - -- sequence_of_statements ] - -- END IF [ IF_label ] ; - -- - -- FIXME: end label. - function Parse_If_Statement (Parent : Iir) return Iir_If_Statement - is - Res: Iir_If_Statement; - Clause: Iir; - N_Clause: Iir; - Start_Loc, Then_Loc, End_Loc : Location_Type; - begin - Res := Create_Iir (Iir_Kind_If_Statement); - Start_Loc := Get_Token_Location; - Set_Location (Res, Start_Loc); - Set_Parent (Res, Parent); - - -- Eat 'if'. - Scan; - - Clause := Res; - loop - Set_Condition (Clause, Parse_Expression); - Then_Loc := Get_Token_Location; - if Current_Token = Tok_Then then - -- Eat 'then'. - Scan; - else - Expect_Error (Tok_Then, "'then' is expected here"); - end if; - - Set_Sequential_Statement_Chain - (Clause, Parse_Sequential_Statements (Res)); - - End_Loc := Get_Token_Location; - - if Flag_Elocations then - Create_Elocations (Clause); - Set_Start_Location (Clause, Start_Loc); - Set_Then_Location (Clause, Then_Loc); - Set_End_Location (Clause, End_Loc); - end if; - - exit when Current_Token /= Tok_Else and Current_Token /= Tok_Elsif; - - N_Clause := Create_Iir (Iir_Kind_Elsif); - Start_Loc := Get_Token_Location; - Set_Location (N_Clause, Start_Loc); - Set_Else_Clause (Clause, N_Clause); - Clause := N_Clause; - if Current_Token = Tok_Else then - - -- Skip 'else'. - Scan; - - Set_Sequential_Statement_Chain - (Clause, Parse_Sequential_Statements (Res)); - - if Flag_Elocations then - Create_Elocations (Clause); - Set_Start_Location (Clause, Start_Loc); - Set_End_Location (Clause, Get_Token_Location); - end if; - - exit; - elsif Current_Token = Tok_Elsif then - -- Skip 'elsif'. - Scan; - else - raise Program_Error; - end if; - end loop; - - -- Skip 'end' 'if' - Expect_Scan (Tok_End); - Expect_Scan (Tok_If); - - return Res; - end Parse_If_Statement; - - function Parenthesis_Name_To_Procedure_Call (Name: Iir; Kind : Iir_Kind) - return Iir - is - Res: Iir; - Call : Iir_Procedure_Call; - Prefix : Iir; - begin - Res := Create_Iir (Kind); - if Name = Null_Iir then - Set_Location (Res); - return Res; - end if; - - Location_Copy (Res, Name); - Call := Create_Iir (Iir_Kind_Procedure_Call); - Location_Copy (Call, Name); - Set_Procedure_Call (Res, Call); - case Get_Kind (Name) is - when Iir_Kind_Parenthesis_Name => - Prefix := Get_Prefix (Name); - if Get_Kind (Prefix) = Iir_Kind_Operator_Symbol then - Error_Msg_Parse - (+Prefix, "operator cannot be used as procedure call"); - end if; - Set_Prefix (Call, Prefix); - Set_Parameter_Association_Chain - (Call, Get_Association_Chain (Name)); - Free_Iir (Name); - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - Set_Prefix (Call, Name); - when Iir_Kind_String_Literal8 => - Error_Msg_Parse - ("string or operator cannot be used as procedure call"); - when Iir_Kind_Selected_By_All_Name - | Iir_Kind_Qualified_Expression - | Iir_Kind_Attribute_Name - | Iir_Kind_Operator_Symbol - | Iir_Kind_Signature => - Error_Msg_Parse - ("invalid name for a procedure call or missing assignment"); - when others => - Error_Kind ("parenthesis_name_to_procedure_call", Name); - end case; - return Res; - end Parenthesis_Name_To_Procedure_Call; - - -- precond : identifier - -- postcond: next token - -- - -- [ LRM93 8.9 ] - -- parameter_specification ::= identifier IN discrete_range - function Parse_Parameter_Specification (Parent : Iir) - return Iir_Iterator_Declaration - is - Decl : Iir_Iterator_Declaration; - begin - Decl := Create_Iir (Iir_Kind_Iterator_Declaration); - Set_Parent (Decl, Parent); - - -- Skip identifier - Scan_Identifier (Decl); - - -- Skip 'in' - Expect_Scan (Tok_In); - - Set_Discrete_Range (Decl, Parse_Discrete_Range); - return Decl; - end Parse_Parameter_Specification; - - -- precond: '<=' - -- postcond: next token - -- - -- [ LRM93 8.4 ] - -- signal_assignment_statement ::= - -- [ label : ] target <= [ delay_mechanism ] waveform ; - -- - -- [ LRM08 10.5 Signal assignment statement ] - -- signal_assignement_statement ::= - -- [ label : ] simple_signal_assignement - -- | [ label : ] conditional_signal_assignement - -- | [ label : ] selected_signal_assignement (TODO) - function Parse_Signal_Assignment_Statement (Target : Iir) return Iir - is - Stmt : Iir; - N_Stmt : Iir; - Wave_Chain : Iir; - begin - Stmt := Create_Iir (Iir_Kind_Simple_Signal_Assignment_Statement); - Set_Location (Stmt); - Set_Target (Stmt, Target); - - -- Skip '<='. - Scan; - - Parse_Delay_Mechanism (Stmt); - - Wave_Chain := Parse_Conditional_Waveforms; - - -- LRM 8.4 Signal assignment statement - -- It is an error is the reserved word UNAFFECTED appears as a - -- waveform in a (sequential) signal assignment statement. - if Get_Kind (Wave_Chain) = Iir_Kind_Unaffected_Waveform then - if Flags.Vhdl_Std < Vhdl_08 then - Error_Msg_Parse - ("'unaffected' is not allowed in a sequential statement"); - end if; - Set_Waveform_Chain (Stmt, Wave_Chain); - elsif Get_Kind (Wave_Chain) = Iir_Kind_Conditional_Waveform then - if Flags.Vhdl_Std < Vhdl_08 then - Error_Msg_Parse - ("conditional signal assignment not allowed in before vhdl08"); - end if; - N_Stmt := - Create_Iir (Iir_Kind_Conditional_Signal_Assignment_Statement); - Location_Copy (N_Stmt, Stmt); - Set_Target (N_Stmt, Target); - Set_Delay_Mechanism (N_Stmt, Get_Delay_Mechanism (Stmt)); - Set_Reject_Time_Expression - (N_Stmt, Get_Reject_Time_Expression (Stmt)); - Set_Conditional_Waveform_Chain (N_Stmt, Wave_Chain); - Free_Iir (Stmt); - Stmt := N_Stmt; - else - Set_Waveform_Chain (Stmt, Wave_Chain); - end if; - - return Stmt; - end Parse_Signal_Assignment_Statement; - - -- precond: WHEN - -- postcond: next token - -- - -- [ LRM08 10.5.3 Conditional signal assignments ] - -- conditional_expressions ::= - -- expression WHEN condition - -- { ELSE expression WHEN condition } - -- [ ELSE expression ] - function Parse_Conditional_Expression (Expr : Iir) return Iir - is - Res : Iir; - El, N_El : Iir; - begin - Res := Create_Iir (Iir_Kind_Conditional_Expression); - Set_Location (Res); - Set_Expression (Res, Expr); - El := Res; - - loop - -- Skip 'when'. - Scan; - - Set_Condition (El, Parse_Expression); - - exit when Current_Token /= Tok_Else; - - N_El := Create_Iir (Iir_Kind_Conditional_Expression); - Set_Location (N_El); - Set_Chain (El, N_El); - El := N_El; - - -- Skip 'else'. - Scan; - - Set_Expression (N_El, Parse_Expression); - - exit when Current_Token /= Tok_When; - end loop; - - return Res; - end Parse_Conditional_Expression; - - -- precond: ':=' - -- postcond: next token - -- - -- [ LRM93 8.5 ] - -- variable_assignment_statement ::= - -- [ label : ] target := expression ; - function Parse_Variable_Assignment_Statement (Target : Iir) return Iir - is - Stmt : Iir; - Loc : Location_Type; - Expr : Iir; - begin - Loc := Get_Token_Location; - - -- Skip ':='. - Scan; - - Expr := Parse_Expression; - - if Current_Token = Tok_When then - if Flags.Vhdl_Std < Vhdl_08 then - Error_Msg_Parse - ("conditional variable assignment not allowed before vhdl08"); - end if; - Stmt := - Create_Iir (Iir_Kind_Conditional_Variable_Assignment_Statement); - Set_Location (Stmt, Loc); - Set_Target (Stmt, Target); - Set_Conditional_Expression - (Stmt, Parse_Conditional_Expression (Expr)); - else - Stmt := Create_Iir (Iir_Kind_Variable_Assignment_Statement); - Set_Location (Stmt, Loc); - Set_Target (Stmt, Target); - Set_Expression (Stmt, Expr); - end if; - return Stmt; - end Parse_Variable_Assignment_Statement; - - -- precond: '<=', ':=' or ';' - -- postcond: next token - function Parse_Sequential_Assignment_Statement (Target : Iir) return Iir - is - Stmt : Iir; - Call : Iir; - begin - if Current_Token = Tok_Less_Equal then - return Parse_Signal_Assignment_Statement (Target); - elsif Current_Token = Tok_Assign then - return Parse_Variable_Assignment_Statement (Target); - elsif Current_Token = Tok_Semi_Colon then - return Parenthesis_Name_To_Procedure_Call - (Target, Iir_Kind_Procedure_Call_Statement); - else - Error_Msg_Parse - ("""<="" or "":="" expected instead of %t", +Current_Token); - Stmt := Create_Iir (Iir_Kind_Procedure_Call_Statement); - Call := Create_Iir (Iir_Kind_Procedure_Call); - Set_Prefix (Call, Target); - Set_Procedure_Call (Stmt, Call); - Set_Location (Call); - Resync_To_End_Of_Statement; - return Stmt; - end if; - end Parse_Sequential_Assignment_Statement; - - -- precond: CASE - -- postcond: ';' - -- - -- [ LRM93 8.8 ] - -- case_statement ::= - -- [ CASE_label : ] - -- CASE expression IS - -- case_statement_alternative - -- { case_statement_alternative } - -- END CASE [ CASE_label ] ; - -- - -- [ LRM93 8.8 ] - -- case_statement_alternative ::= WHEN choices => sequence_of_statements - function Parse_Case_Statement (Label : Name_Id) return Iir - is - use Iir_Chains.Case_Statement_Alternative_Chain_Handling; - Stmt : Iir; - Assoc: Iir; - Last_Assoc : Iir; - When_Loc : Location_Type; - begin - Stmt := Create_Iir (Iir_Kind_Case_Statement); - Set_Label (Stmt, Label); - Set_Location (Stmt); - - -- Skip 'case'. - Scan; - - Set_Expression (Stmt, Parse_Expression); - - -- Skip 'is'. - Expect (Tok_Is); - Scan; - - if Current_Token = Tok_End then - Error_Msg_Parse ("missing alternative in case statement"); - end if; - - Build_Init (Last_Assoc); - while Current_Token = Tok_When loop - When_Loc := Get_Token_Location; - - -- Skip 'when'. - Scan; - - Parse_Choices (Null_Iir, When_Loc, Assoc); - - -- Skip '=>'. - Expect_Scan (Tok_Double_Arrow); - - Set_Associated_Chain (Assoc, Parse_Sequential_Statements (Stmt)); - Append_Subchain (Last_Assoc, Stmt, Assoc); - end loop; - - if Flag_Elocations then - Create_Elocations (Stmt); - Set_End_Location (Stmt, Get_Token_Location); - end if; - - -- Skip 'end', 'case'. - Expect_Scan (Tok_End); - Expect_Scan (Tok_Case); - - if Flags.Vhdl_Std >= Vhdl_93c then - Check_End_Name (Stmt); - end if; - - return Stmt; - end Parse_Case_Statement; - - -- precond: FOR - -- postcond: ';' - -- - -- [ LRM93 8.9 ] - -- loop_statement ::= - -- [ LOOP_label : ] - -- [ iteration_scheme ] LOOP - -- sequence_of_statements - -- END LOOP [ LOOP_label ] ; - -- - -- [ LRM93 8.9 ] - -- iteration_scheme ::= WHILE condition - -- | FOR LOOP_parameter_specification - function Parse_For_Loop_Statement (Label : Name_Id) return Iir - is - Stmt : Iir; - Start_Loc, Loop_Loc, End_Loc : Location_Type; - begin - Stmt := Create_Iir (Iir_Kind_For_Loop_Statement); - Start_Loc := Get_Token_Location; - Set_Location (Stmt, Start_Loc); - Set_Label (Stmt, Label); - - -- Skip 'for' - Scan; - - Set_Parameter_Specification - (Stmt, Parse_Parameter_Specification (Stmt)); - - -- Skip 'loop' - Loop_Loc := Get_Token_Location; - Expect (Tok_Loop); - Scan; - - Set_Sequential_Statement_Chain - (Stmt, Parse_Sequential_Statements (Stmt)); - - -- Skip 'end' - End_Loc := Get_Token_Location; - Expect_Scan (Tok_End); - - -- Skip 'loop' - Expect_Scan (Tok_Loop); - - Check_End_Name (Stmt); - - if Flag_Elocations then - Create_Elocations (Stmt); - Set_Start_Location (Stmt, Start_Loc); - Set_Loop_Location (Stmt, Loop_Loc); - Set_End_Location (Stmt, End_Loc); - end if; - - return Stmt; - end Parse_For_Loop_Statement; - - -- precond: WHILE or LOOP - -- postcond: ';' - -- - -- [ 8.9 ] - -- loop_statement ::= - -- [ LOOP_label : ] - -- [ iteration_scheme ] LOOP - -- sequence_of_statements - -- END LOOP [ LOOP_label ] ; - function Parse_While_Loop_Statement (Label : Name_Id) return Iir - is - Stmt : Iir; - Start_Loc, Loop_Loc, End_Loc : Location_Type; - begin - Stmt := Create_Iir (Iir_Kind_While_Loop_Statement); - Start_Loc := Get_Token_Location; - Set_Location (Stmt, Start_Loc); - Set_Label (Stmt, Label); - if Current_Token = Tok_While then - -- Skip 'while'. - Scan; - - Set_Condition (Stmt, Parse_Expression); - Expect (Tok_Loop); - end if; - - -- Skip 'loop'. - Loop_Loc := Get_Token_Location; - Scan; - - Set_Sequential_Statement_Chain - (Stmt, Parse_Sequential_Statements (Stmt)); - - End_Loc := Get_Token_Location; - - -- Skip 'end'. - Expect_Scan (Tok_End); - - -- Skip 'loop'. - Expect_Scan (Tok_Loop); - - Check_End_Name (Stmt); - - if Flag_Elocations then - Create_Elocations (Stmt); - Set_Start_Location (Stmt, Start_Loc); - Set_Loop_Location (Stmt, Loop_Loc); - Set_End_Location (Stmt, End_Loc); - end if; - - return Stmt; - end Parse_While_Loop_Statement; - - -- precond: next token - -- postcond: next token - -- - -- [ LRM93 8 ] - -- sequence_of_statement ::= { sequential_statement } - -- - -- [ 8 ] - -- sequential_statement ::= wait_statement - -- | assertion_statement - -- | report_statement - -- | signal_assignment_statement - -- | variable_assignment_statement - -- | procedure_call_statement - -- | if_statement - -- | case_statement - -- | loop_statement - -- | next_statement - -- | exit_statement - -- | return_statement - -- | null_statement - -- - -- [ 8.13 ] - -- null_statement ::= [ label : ] NULL ; - -- - -- [ 8.12 ] - -- return_statement ::= [ label : ] RETURN [ expression ] - -- - -- [ 8.10 ] - -- next_statement ::= [ label : ] NEXT [ LOOP_label ] [ WHEN condition ] ; - -- - -- [ 8.11 ] - -- exit_statement ::= [ label : ] EXIT [ LOOP_label ] [ WHEN condition ] ; - -- - -- [ 8.9 ] - -- loop_statement ::= - -- [ LOOP_label : ] - -- [ iteration_scheme ] LOOP - -- sequence_of_statements - -- END LOOP [ LOOP_label ] ; - -- - -- [ 8.9 ] - -- iteration_scheme ::= WHILE condition - -- | FOR LOOP_parameter_specification - -- - -- [ 8.2 ] - -- assertion_statement ::= [ label : ] assertion ; - -- - -- [ 8.3 ] - -- report_statement ::= [ label : ] REPORT expression SEVERITY expression ; - function Parse_Sequential_Statements (Parent : Iir) - return Iir - is - First_Stmt : Iir; - Last_Stmt : Iir; - Stmt: Iir; - Label: Name_Id; - Loc : Location_Type; - Target : Iir; - begin - First_Stmt := Null_Iir; - Last_Stmt := Null_Iir; - -- Expect a current_token. - loop - Loc := Get_Token_Location; - if Current_Token = Tok_Identifier then - Label := Current_Identifier; - - -- Skip identifier. - Scan; - - if Current_Token = Tok_Colon then - -- Skip ':'. - Scan; - else - Target := Create_Iir (Iir_Kind_Simple_Name); - Set_Identifier (Target, Label); - Set_Location (Target, Loc); - Label := Null_Identifier; - Target := Parse_Name_Suffix (Target, True); - Stmt := Parse_Sequential_Assignment_Statement (Target); - goto Has_Stmt; - end if; - else - Label := Null_Identifier; - end if; - - case Current_Token is - when Tok_Null => - Stmt := Create_Iir (Iir_Kind_Null_Statement); - - -- Skip 'null'. - Scan; - - when Tok_Assert => - Stmt := Create_Iir (Iir_Kind_Assertion_Statement); - Parse_Assertion (Stmt); - when Tok_Report => - Stmt := Parse_Report_Statement; - when Tok_If => - Stmt := Parse_If_Statement (Parent); - Set_Label (Stmt, Label); - Set_Location (Stmt, Loc); - if Flags.Vhdl_Std >= Vhdl_93c then - Check_End_Name (Stmt); - end if; - when Tok_Case => - Stmt := Parse_Case_Statement (Label); - when Tok_Identifier - | Tok_String => - -- String for an expanded name with operator_symbol prefix. - Stmt := Parse_Sequential_Assignment_Statement (Parse_Name); - when Tok_Left_Paren => - declare - Target : Iir; - begin - Target := Parse_Aggregate; - if Current_Token = Tok_Less_Equal then - Stmt := Parse_Signal_Assignment_Statement (Target); - elsif Current_Token = Tok_Assign then - Stmt := Parse_Variable_Assignment_Statement (Target); - else - Error_Msg_Parse ("'<=' or ':=' expected"); - return First_Stmt; - end if; - end; - - when Tok_Return => - Stmt := Create_Iir (Iir_Kind_Return_Statement); - - -- Skip return. - Scan; - - if Current_Token /= Tok_Semi_Colon then - Set_Expression (Stmt, Parse_Expression); - end if; - - when Tok_For => - Stmt := Parse_For_Loop_Statement (Label); - Set_Location (Stmt, Loc); - - -- A loop statement can have a label, even in vhdl87. - Label := Null_Identifier; - - when Tok_While - | Tok_Loop => - Stmt := Parse_While_Loop_Statement (Label); - Set_Location (Stmt, Loc); - - -- A loop statement can have a label, even in vhdl87. - Label := Null_Identifier; - - when Tok_Next - | Tok_Exit => - if Current_Token = Tok_Next then - Stmt := Create_Iir (Iir_Kind_Next_Statement); - else - Stmt := Create_Iir (Iir_Kind_Exit_Statement); - end if; - - -- Skip 'next' or 'exit'. - Scan; - - if Current_Token = Tok_Identifier then - Set_Loop_Label (Stmt, Parse_Name (Allow_Indexes => False)); - end if; - - if Current_Token = Tok_When then - -- Skip 'when'. - Scan; - - Set_Condition (Stmt, Parse_Expression); - end if; - - when Tok_Wait => - Stmt := Parse_Wait_Statement; - - when Tok_Semi_Colon => - Error_Msg_Parse ("extra ';' ignored"); - - -- Eat ';' - Scan; - - goto Again; - when others => - return First_Stmt; - end case; - << Has_Stmt >> null; - Set_Parent (Stmt, Parent); - Set_Location (Stmt, Loc); - if Label /= Null_Identifier then - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse - (+Stmt, "this statement can't have a label in vhdl 87"); - else - Set_Label (Stmt, Label); - end if; - end if; - - if Current_Token = Tok_Semi_Colon then - -- Skip ';'. - Scan; - else - Error_Missing_Semi_Colon ("statement"); - Resync_To_End_Of_Statement; - if Current_Token = Tok_Semi_Colon then - -- Skip ';'. - Scan; - end if; - end if; - - -- Append it to the chain. - if First_Stmt = Null_Iir then - First_Stmt := Stmt; - else - Set_Chain (Last_Stmt, Stmt); - end if; - Last_Stmt := Stmt; - - <> null; - end loop; - end Parse_Sequential_Statements; - - -- precond : PROCEDURE, FUNCTION, PURE or IMPURE. - -- postcond: next token. - -- - -- [ LRM93 2.1 ] - -- subprogram_declaration ::= subprogram_specification ; - -- - -- [ LRM93 2.1 ] - -- subprogram_specification ::= - -- PROCEDURE designator [ ( formal_parameter_list ) ] - -- | [ PURE | IMPURE ] FUNCTION designator [ ( formal_parameter_list ) ] - -- RETURN type_mark - -- - -- [ LRM93 2.2 ] - -- subprogram_body ::= - -- subprogram_specification IS - -- subprogram_declarative_part - -- BEGIN - -- subprogram_statement_part - -- END [ subprogram_kind ] [ designator ] ; - -- - -- [ LRM93 2.1 ] - -- designator ::= identifier | operator_symbol - -- - -- [ LRM93 2.1 ] - -- operator_symbol ::= string_literal - function Parse_Subprogram_Declaration return Iir - is - Kind : Iir_Kind; - Subprg: Iir; - Subprg_Body : Iir; - Start_Loc, Is_Loc, Begin_Loc, End_Loc : Location_Type; - begin - -- Create the node. - Start_Loc := Get_Token_Location; - case Current_Token is - when Tok_Procedure => - Kind := Iir_Kind_Procedure_Declaration; - when Tok_Function - | Tok_Pure - | Tok_Impure => - Kind := Iir_Kind_Function_Declaration; - when others => - raise Internal_Error; - end case; - Subprg := Create_Iir (Kind); - Set_Location (Subprg); - Set_Implicit_Definition (Subprg, Iir_Predefined_None); - - case Current_Token is - when Tok_Procedure => - null; - when Tok_Function => - -- LRM93 2.1 - -- A function is impure if its specification contains the - -- reserved word IMPURE; otherwise it is said to be pure. - Set_Pure_Flag (Subprg, True); - when Tok_Pure - | Tok_Impure => - Set_Pure_Flag (Subprg, Current_Token = Tok_Pure); - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse - ("'pure' and 'impure' are not allowed in vhdl 87"); - end if; - Set_Has_Pure (Subprg, True); - -- FIXME: what to do in case of error ?? - - -- Eat 'pure' or 'impure'. - Scan; - - Expect (Tok_Function, "'function' must follow 'pure' or 'impure'"); - when others => - raise Internal_Error; - end case; - - -- Eat 'procedure' or 'function'. - Scan; - - -- Designator. - Parse_Subprogram_Designator (Subprg); - - Parse_Subprogram_Parameters_And_Return - (Subprg, Kind = Iir_Kind_Function_Declaration); - - if Flag_Elocations then - Create_Elocations (Subprg); - Set_Start_Location (Subprg, Start_Loc); - end if; - - if Current_Token /= Tok_Is then - -- Skip ';'. - Expect_Scan (Tok_Semi_Colon); - - return Subprg; - end if; - - -- Skip 'is'. - Is_Loc := Get_Token_Location; - Scan; - - -- The body. - Set_Has_Body (Subprg, True); - if Kind = Iir_Kind_Function_Declaration then - Subprg_Body := Create_Iir (Iir_Kind_Function_Body); - else - Subprg_Body := Create_Iir (Iir_Kind_Procedure_Body); - end if; - Location_Copy (Subprg_Body, Subprg); - - Set_Subprogram_Body (Subprg, Subprg_Body); - Set_Subprogram_Specification (Subprg_Body, Subprg); - Set_Chain (Subprg, Subprg_Body); - - Parse_Declarative_Part (Subprg_Body); - - -- Skip 'begin'. - Begin_Loc := Get_Token_Location; - Expect_Scan (Tok_Begin); - - Set_Sequential_Statement_Chain - (Subprg_Body, Parse_Sequential_Statements (Subprg_Body)); - - -- Skip 'end'. - End_Loc := Get_Token_Location; - Expect_Scan (Tok_End); - - if Flag_Elocations then - Create_Elocations (Subprg_Body); - Set_Is_Location (Subprg_Body, Is_Loc); - Set_Begin_Location (Subprg_Body, Begin_Loc); - Set_End_Location (Subprg_Body, End_Loc); - end if; - - case Current_Token is - when Tok_Function => - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse ("'function' not allowed here by vhdl 87"); - end if; - if Kind = Iir_Kind_Procedure_Declaration then - Error_Msg_Parse ("'procedure' expected instead of 'function'"); - end if; - Set_End_Has_Reserved_Id (Subprg_Body, True); - - -- Skip 'function'. - Scan; - - when Tok_Procedure => - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse ("'procedure' not allowed here by vhdl 87"); - end if; - if Kind = Iir_Kind_Function_Declaration then - Error_Msg_Parse ("'function' expected instead of 'procedure'"); - end if; - Set_End_Has_Reserved_Id (Subprg_Body, True); - - -- Skip 'procedure' - Scan; - - when others => - null; - end case; - case Current_Token is - when Tok_Identifier => - Check_End_Name (Get_Identifier (Subprg), Subprg_Body); - when Tok_String => - if Scan_To_Operator_Name (Get_Token_Location) - /= Get_Identifier (Subprg) - then - Error_Msg_Parse ("misspelling, %i expected", +Subprg); - end if; - Set_End_Has_Identifier (Subprg_Body, True); - - -- Skip string. - Scan; - - when others => - null; - end case; - Scan_Semi_Colon_Declaration ("subprogram body"); - - return Subprg; - end Parse_Subprogram_Declaration; - - -- precond: PROCESS - -- postcond: next token - -- - -- [ LRM87 9.2 / LRM08 11.3 ] - -- process_statement ::= - -- [ PROCESS_label : ] - -- [ POSTPONED ] PROCESS [ ( process_sensitivity_list ) ] [ IS ] - -- process_declarative_part - -- BEGIN - -- process_statement_part - -- END [ POSTPONED ] PROCESS [ PROCESS_label ] ; - -- - -- process_sensitivity_list ::= ALL | sensitivity_list - function Parse_Process_Statement - (Label: Name_Id; Loc : Location_Type; Is_Postponed : Boolean) - return Iir - is - Res: Iir; - Sensitivity_List : Iir_List; - Start_Loc, Begin_Loc, End_Loc : Location_Type; - begin - Start_Loc := Get_Token_Location; - - -- Skip 'process' - Scan; - - if Current_Token = Tok_Left_Paren then - Res := Create_Iir (Iir_Kind_Sensitized_Process_Statement); - - -- Skip '(' - Scan; - - if Current_Token = Tok_All then - if Vhdl_Std < Vhdl_08 then - Error_Msg_Parse - ("all sensitized process allowed only in vhdl 08"); - end if; - Sensitivity_List := Iir_List_All; - - -- Skip 'all' - Scan; - else - Sensitivity_List := Create_Iir_List; - Parse_Sensitivity_List (Sensitivity_List); - end if; - Set_Sensitivity_List (Res, Sensitivity_List); - - -- Skip ')' - Expect (Tok_Right_Paren); - Scan; - else - Res := Create_Iir (Iir_Kind_Process_Statement); - end if; - - Set_Location (Res, Loc); - Set_Label (Res, Label); - Set_Has_Label (Res, Label /= Null_Identifier); - - if Current_Token = Tok_Is then - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse ("""is"" not allowed here by vhdl 87"); - end if; - Set_Has_Is (Res, True); - - -- Skip 'is' - Scan; - end if; - - -- declarative part. - Parse_Declarative_Part (Res); - - -- Skip 'begin'. - Begin_Loc := Get_Token_Location; - Expect_Scan (Tok_Begin); - - Set_Sequential_Statement_Chain (Res, Parse_Sequential_Statements (Res)); - - -- Skip 'end'. - End_Loc := Get_Token_Location; - Expect_Scan (Tok_End); - - if Current_Token = Tok_Postponed then - if not Is_Postponed then - -- LRM93 9.2 - -- If the reserved word POSTPONED appears at the end of a process - -- statement, the process must be a postponed process. - Error_Msg_Parse ("process is not a postponed process"); - end if; - - Set_End_Has_Postponed (Res, True); - - -- Skip 'postponed', - Scan; - end if; - - if Current_Token = Tok_Semi_Colon then - Error_Msg_Parse ("""end"" must be followed by ""process"""); - - -- Skip ';'. - Scan; - else - Expect_Scan (Tok_Process); - Set_End_Has_Reserved_Id (Res, True); - Check_End_Name (Res); - Expect_Scan (Tok_Semi_Colon, "';' expected at end of process"); - end if; - - if Flag_Elocations then - Create_Elocations (Res); - Set_Start_Location (Res, Start_Loc); - Set_Begin_Location (Res, Begin_Loc); - Set_End_Location (Res, End_Loc); - end if; - - return Res; - end Parse_Process_Statement; - - function Check_Formal_Form (Formal : Iir) return Iir is - begin - if Formal = Null_Iir then - return Formal; - end if; - - case Get_Kind (Formal) is - when Iir_Kind_Simple_Name - | Iir_Kind_Slice_Name - | Iir_Kind_Selected_Name => - return Formal; - when Iir_Kind_Parenthesis_Name => - -- Could be an indexed name, so nothing to check within the - -- parenthesis. - declare - Assoc : constant Iir := Get_Association_Chain (Formal); - begin - if Assoc /= Null_Iir then - Set_In_Formal_Flag (Assoc, True); - end if; - end; - return Formal; - when Iir_Kind_String_Literal8 => - -- Operator designator - return String_To_Operator_Symbol (Formal); - when others => - Error_Msg_Parse (+Formal, "incorrect formal name ignored"); - return Null_Iir; - end case; - end Check_Formal_Form; - - -- precond : NEXT_TOKEN - -- postcond: NEXT_TOKEN - -- - -- [ LRM93 4.3.2.2 ] - -- association_list ::= association_element { , association_element } - -- - -- [ LRM93 4.3.2.2 ] - -- association_element ::= [ formal_part => ] actual_part - -- - -- [ LRM93 4.3.2.2 ] - -- actual_part ::= actual_designator - -- | FUNCTION_name ( actual_designator ) - -- | type_mark ( actual_designator ) - -- - -- [ LRM93 4.3.2.2 ] - -- actual_designator ::= expression - -- | SIGNAL_name - -- | VARIABLE_name - -- | FILE_name - -- | OPEN - -- - -- [ LRM93 4.3.2.2 ] - -- formal_part ::= formal_designator - -- | FUNCTION_name ( formal_designator ) - -- | type_mark ( formal_designator ) - -- - -- [ LRM93 4.3.2.2 ] - -- formal_designator ::= GENERIC_name - -- | PORT_name - -- | PARAMETER_name - -- - -- Note: an actual part is parsed as an expression. - function Parse_Association_List return Iir - is - Res, Last: Iir; - El: Iir; - Formal: Iir; - Actual: Iir; - Nbr_Assocs : Natural; - Loc : Location_Type; - Arrow_Loc : Location_Type; - Comma_Loc : Location_Type; - begin - Sub_Chain_Init (Res, Last); - - if Current_Token = Tok_Right_Paren then - Error_Msg_Parse ("empty association list is not allowed"); - return Res; - end if; - - Nbr_Assocs := 1; - loop - -- Parse formal and actual. - Loc := Get_Token_Location; - Arrow_Loc := No_Location; - Formal := Null_Iir; - - if Current_Token /= Tok_Open then - Actual := Parse_Expression; - case Current_Token is - when Tok_To - | Tok_Downto => - -- To/downto can appear in slice name. - - if Actual = Null_Iir then - -- Left expression is missing ie: (downto x). - Scan; - Actual := Parse_Expression; - else - Actual := Parse_Range_Expression (Actual); - end if; - if Nbr_Assocs /= 1 then - Error_Msg_Parse ("multi-dimensional slice is forbidden"); - end if; - - when Tok_Double_Arrow => - -- Check that FORMAL is a name and not an expression. - Formal := Check_Formal_Form (Actual); - Arrow_Loc := Get_Token_Location; - - -- Skip '=>' - Scan; - Loc := Get_Token_Location; - - if Current_Token /= Tok_Open then - Actual := Parse_Expression; - end if; - - when others => - null; - end case; - end if; - - if Current_Token = Tok_Open then - El := Create_Iir (Iir_Kind_Association_Element_Open); - Set_Location (El); - - -- Skip 'open' - Scan; - else - El := Create_Iir (Iir_Kind_Association_Element_By_Expression); - Set_Location (El, Loc); - Set_Actual (El, Actual); - end if; - Set_Formal (El, Formal); - - if Flag_Elocations then - Create_Elocations (El); - Set_Arrow_Location (El, Arrow_Loc); - end if; - - Sub_Chain_Append (Res, Last, El); - exit when Current_Token /= Tok_Comma; - - -- Eat ','. - Comma_Loc := Get_Token_Location; - Scan; - - if Current_Token = Tok_Right_Paren then - Error_Msg_Parse (Comma_Loc, "extra ',' ignored"); - exit; - end if; - - Nbr_Assocs := Nbr_Assocs + 1; - end loop; - - return Res; - end Parse_Association_List; - - -- precond : NEXT_TOKEN - -- postcond: NEXT_TOKEN - -- - -- Parse: '(' association_list ')' - function Parse_Association_List_In_Parenthesis return Iir - is - Res : Iir; - begin - -- Skip '(' - Expect_Scan (Tok_Left_Paren); - - Res := Parse_Association_List; - - -- Skip ')' - Expect_Scan (Tok_Right_Paren); - - return Res; - end Parse_Association_List_In_Parenthesis; - - -- precond : GENERIC - -- postcond: next token - -- - -- [ LRM93 5.2.1.2, LRM08 6.5.7.2 ] - -- generic_map_aspect ::= GENERIC MAP ( GENERIC_association_list ) - function Parse_Generic_Map_Aspect return Iir is - begin - -- Skip 'generic'. - Expect_Scan (Tok_Generic); - - -- Skip 'map'. - Expect_Scan (Tok_Map); - - return Parse_Association_List_In_Parenthesis; - end Parse_Generic_Map_Aspect; - - -- precond : PORT - -- postcond: next token - -- - -- [ LRM93 5.2.1.2 ] - -- port_map_aspect ::= PORT MAP ( PORT_association_list ) - function Parse_Port_Map_Aspect return Iir is - begin - -- Skip 'port'. - Expect_Scan (Tok_Port); - - -- Skip 'map'. - Expect_Scan (Tok_Map); - - return Parse_Association_List_In_Parenthesis; - end Parse_Port_Map_Aspect; - - -- precond : COMPONENT | ENTIY | CONFIGURATION - -- postcond : next_token - -- - -- instantiated_unit ::= - -- [ COMPONENT ] component_name - -- | ENTITY entity_name [ ( architecture_identifier ) ] - -- | CONFIGURATION configuration_name - function Parse_Instantiated_Unit return Iir - is - Res : Iir; - begin - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse - ("component instantiation using keyword 'component', 'entity',", - Cont => True); - Error_Msg_Parse (" or 'configuration' is not allowed in vhdl87"); - end if; - - case Current_Token is - when Tok_Component => - -- Eat 'component'. - Scan; - - return Parse_Name (False); - - when Tok_Entity => - Res := Create_Iir (Iir_Kind_Entity_Aspect_Entity); - Set_Location (Res); - - -- Eat 'entity'. - Scan; - - Set_Entity_Name (Res, Parse_Name (False)); - if Current_Token = Tok_Left_Paren then - -- Skip '('. - Scan; - - if Current_Token = Tok_Identifier then - Set_Architecture (Res, Current_Text); - - -- Skip identifier. - Scan; - else - Expect (Tok_Identifier, "identifier for architecture"); - end if; - - -- Skip ')'. - Expect_Scan (Tok_Right_Paren); - end if; - return Res; - - when Tok_Configuration => - Res := Create_Iir (Iir_Kind_Entity_Aspect_Configuration); - Set_Location (Res); - - -- Skip 'configuration. - Scan; - - Expect (Tok_Identifier); - Set_Configuration_Name (Res, Parse_Name (False)); - return Res; - - when others => - raise Internal_Error; - end case; - end Parse_Instantiated_Unit; - - -- precond : next token - -- postcond: next token - -- - -- component_instantiation_statement ::= - -- INSTANTIATION_label : - -- instantiated_unit [ generic_map_aspect ] [ port_map_aspect ] ; - function Parse_Component_Instantiation (Name: Iir) - return Iir_Component_Instantiation_Statement - is - Res: Iir_Component_Instantiation_Statement; - begin - Res := Create_Iir (Iir_Kind_Component_Instantiation_Statement); - Set_Location (Res); - - Set_Instantiated_Unit (Res, Name); - - if Current_Token = Tok_Generic then - Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect); - end if; - if Current_Token = Tok_Port then - Set_Port_Map_Aspect_Chain (Res, Parse_Port_Map_Aspect); - end if; - Expect_Scan (Tok_Semi_Colon); - return Res; - end Parse_Component_Instantiation; - - -- precond : next token - -- postcond: next token - -- - -- [ LRM93 9.1 ] - -- block_header ::= [ generic_clause [ generic_map_aspect ; ] ] - -- [ port_clause [ port_map_aspect ; ] ] - function Parse_Block_Header return Iir_Block_Header is - Res : Iir_Block_Header; - begin - Res := Create_Iir (Iir_Kind_Block_Header); - Set_Location (Res); - if Current_Token = Tok_Generic then - Parse_Generic_Clause (Res); - if Current_Token = Tok_Generic then - Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect); - Scan_Semi_Colon ("generic map aspect"); - end if; - end if; - if Current_Token = Tok_Port then - Parse_Port_Clause (Res); - if Current_Token = Tok_Port then - Set_Port_Map_Aspect_Chain (Res, Parse_Port_Map_Aspect); - Scan_Semi_Colon ("port map aspect"); - end if; - end if; - return Res; - end Parse_Block_Header; - - -- precond : BLOCK - -- postcond: ';' - -- - -- [ LRM93 9.1 ] - -- block_statement ::= - -- BLOCK_label : - -- BLOCK [ ( GUARD_expression ) ] [ IS ] - -- block_header - -- block_declarative_part - -- BEGIN - -- block_statement_part - -- END BLOCK [ BLOCK_label ] ; - -- - -- [ LRM93 9.1 ] - -- block_declarative_part ::= { block_declarative_item } - -- - -- [ LRM93 9.1 ] - -- block_statement_part ::= { concurrent_statement } - function Parse_Block_Statement (Label: Name_Id; Loc : Location_Type) - return Iir_Block_Statement - is - Res : Iir_Block_Statement; - Guard : Iir_Guard_Signal_Declaration; - Begin_Loc : Location_Type; - begin - if Label = Null_Identifier then - Error_Msg_Parse ("a block statement must have a label"); - end if; - - -- block was just parsed. - Res := Create_Iir (Iir_Kind_Block_Statement); - Set_Location (Res, Loc); - Set_Label (Res, Label); - - -- Eat 'block'. - Scan; - - if Current_Token = Tok_Left_Paren then - Guard := Create_Iir (Iir_Kind_Guard_Signal_Declaration); - Set_Location (Guard); - Set_Guard_Decl (Res, Guard); - - -- Eat '('. - Scan; - - Set_Guard_Expression (Guard, Parse_Expression); - - -- Eat ')'. - Expect_Scan (Tok_Right_Paren, "')' expected after guard expression"); - end if; - - if Current_Token = Tok_Is then - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse ("'is' not allowed here in vhdl87"); - end if; - - -- Eat 'is'. - Scan; - end if; - if Current_Token = Tok_Generic or Current_Token = Tok_Port then - Set_Block_Header (Res, Parse_Block_Header); - end if; - if Current_Token /= Tok_Begin then - Parse_Declarative_Part (Res); - end if; - - Begin_Loc := Get_Token_Location; - - -- Eat 'begin'. - Expect_Scan (Tok_Begin); - - Parse_Concurrent_Statements (Res); - - if Flag_Elocations then - Create_Elocations (Res); - Set_Begin_Location (Res, Begin_Loc); - Set_End_Location (Res, Get_Token_Location); - end if; - - Check_End_Name (Tok_Block, Res); - Expect_Scan (Tok_Semi_Colon); - - return Res; - end Parse_Block_Statement; - - -- Precond : next token - -- Postcond: next token after 'end' - -- - -- [ LRM08 11.8 ] Generate statements - -- generate_statement_body ::= - -- [ block_declarative_part - -- BEGIN ] - -- { concurrent_statement } - -- [ END [ alternative_label ] ; ] - -- - -- This corresponds to the following part of LRM93 9.7: - -- [ { block_declarative_item } - -- BEGIN ] - -- { concurrent_statement } - -- Note there is no END. This part is followed by: - -- END GENERATE [ /generate/_label ] ; - procedure Parse_Generate_Statement_Body (Parent : Iir; - Label : Name_Id; - Bod : out Iir; - End_Loc : out Location_Type) - is - function Is_Early_End return Boolean is - begin - case Current_Token is - when Tok_Elsif - | Tok_Else => - if Get_Kind (Parent) = Iir_Kind_If_Generate_Statement then - return True; - end if; - when Tok_When => - if Get_Kind (Parent) = Iir_Kind_Case_Generate_Statement then - return True; - end if; - when others => - null; - end case; - return False; - end Is_Early_End; - begin - Bod := Create_Iir (Iir_Kind_Generate_Statement_Body); - Set_Location (Bod); - Set_Parent (Bod, Parent); - Set_Alternative_Label (Bod, Label); - Set_Has_Label (Bod, Label /= Null_Identifier); - End_Loc := No_Location; - - if Flag_Elocations then - Create_Elocations (Bod); - end if; - - -- Check for a block declarative item. - case Current_Token is - when - -- subprogram_declaration - -- subprogram_body - Tok_Procedure - | Tok_Function - | Tok_Pure - | Tok_Impure - -- type_declaration - | Tok_Type - -- subtype_declaration - | Tok_Subtype - -- constant_declaration - | Tok_Constant - -- signal_declaration - | Tok_Signal - -- shared_variable_declaration - | Tok_Shared - | Tok_Variable - -- file_declaration - | Tok_File - -- alias_declaration - | Tok_Alias - -- component_declaration - | Tok_Component - -- attribute_declaration - -- attribute_specification - | Tok_Attribute - -- configuration_specification - | Tok_For - -- disconnection_specification - | Tok_Disconnect - -- use_clause - | Tok_Use - -- group_template_declaration - -- group_declaration - | Tok_Group - | Tok_Begin => - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse - ("declarations not allowed in a generate in vhdl87"); - end if; - Parse_Declarative_Part (Bod); - Expect (Tok_Begin); - Set_Has_Begin (Bod, True); - - if Flag_Elocations then - Set_Begin_Location (Bod, Get_Token_Location); - end if; - - -- Skip 'begin' - Scan; - when others => - null; - end case; - - Parse_Concurrent_Statements (Bod); - - -- Return now if no 'end' (and not expected). - if Is_Early_End then - return; - end if; - - -- Skip 'end' - End_Loc := Get_Token_Location; - Expect_Scan (Tok_End); - - if Vhdl_Std >= Vhdl_08 and then Current_Token /= Tok_Generate then - -- This is the 'end' of the generate_statement_body. - Set_Has_End (Bod, True); - if Flag_Elocations then - Set_End_Location (Bod, End_Loc); - end if; - - Check_End_Name (Label, Bod); - Scan_Semi_Colon ("generate statement body"); - - -- Return now if no 'end' (and not expected). - if Is_Early_End then - return; - end if; - - Expect (Tok_End); - End_Loc := Get_Token_Location; - - -- Skip 'end' - Scan; - end if; - end Parse_Generate_Statement_Body; - - -- precond : FOR - -- postcond: ';' - -- - -- [ LRM93 9.7 ] - -- generate_statement ::= - -- GENERATE_label : generation_scheme GENERATE - -- [ { block_declarative_item } - -- BEGIN ] - -- { concurrent_statement } - -- END GENERATE [ GENERATE_label ] ; - -- - -- [ LRM93 9.7 ] - -- generation_scheme ::= - -- FOR GENERATE_parameter_specification - -- | IF condition - -- - -- [ LRM08 11.8 ] - -- for_generate_statement ::= - -- /generate/_label : - -- FOR /generate/_parameter_specification GENERATE - -- generate_statement_body - -- END GENERATE [ /generate/_label ] ; - -- - -- FIXME: block_declarative item. - function Parse_For_Generate_Statement (Label : Name_Id; Loc : Location_Type) - return Iir - is - Res : Iir; - Bod : Iir; - Start_Loc, Generate_Loc, End_Loc : Location_Type; - begin - if Label = Null_Identifier then - Error_Msg_Parse ("a generate statement must have a label"); - end if; - Res := Create_Iir (Iir_Kind_For_Generate_Statement); - Set_Location (Res, Loc); - Set_Label (Res, Label); - Start_Loc := Get_Token_Location; - - -- Skip 'for' - Scan; - - Set_Parameter_Specification (Res, Parse_Parameter_Specification (Res)); - - -- Skip 'generate' - Expect (Tok_Generate); - Generate_Loc := Get_Token_Location; - Scan; - - Parse_Generate_Statement_Body (Res, Null_Identifier, Bod, End_Loc); - Set_Generate_Statement_Body (Res, Bod); - - -- Skip 'generate' - Expect_Scan (Tok_Generate); - Set_End_Has_Reserved_Id (Res, True); - - -- LRM93 9.7 - -- If a label appears at the end of a generate statement, it must repeat - -- the generate label. - Check_End_Name (Res); - Expect_Scan (Tok_Semi_Colon); - - if Flag_Elocations then - Create_Elocations (Res); - Set_Start_Location (Res, Start_Loc); - Set_Generate_Location (Res, Generate_Loc); - Set_End_Location (Res, End_Loc); - end if; - - return Res; - end Parse_For_Generate_Statement; - - -- precond : IF - -- postcond: ';' - -- - -- [ LRM93 9.7 ] - -- generate_statement ::= - -- /generate/_label : generation_scheme GENERATE - -- [ { block_declarative_item } - -- BEGIN ] - -- { concurrent_statement } - -- END GENERATE [ /generate/_label ] ; - -- - -- [ LRM93 9.7 ] - -- generation_scheme ::= - -- FOR GENERATE_parameter_specification - -- | IF condition - -- - -- [ LRM08 11.8 ] - -- if_generate_statement ::= - -- /generate/_label : - -- IF [ /alternative/_label : ] condition GENERATE - -- generate_statement_body - -- { ELSIF [ /alternative/_label : ] condition GENERATE - -- generate_statement_body } - -- [ ELSE [ /alternative/_label : ] GENERATE - -- generate_statement_body ] - -- END GENERATE [ /generate/_label ] ; - function Parse_If_Generate_Statement (Label : Name_Id; Loc : Location_Type) - return Iir_Generate_Statement - is - Res : Iir_Generate_Statement; - Alt_Label : Name_Id; - Alt_Loc : Location_Type; - Cond : Iir; - Clause : Iir; - Bod : Iir; - Last : Iir; - Start_Loc, Generate_Loc, End_Loc : Location_Type; - begin - if Label = Null_Identifier then - Error_Msg_Parse ("a generate statement must have a label"); - end if; - Res := Create_Iir (Iir_Kind_If_Generate_Statement); - Set_Location (Res, Loc); - Set_Label (Res, Label); - Start_Loc := Get_Token_Location; - - -- Skip 'if'. - Scan; - - Clause := Res; - Last := Null_Iir; - loop - Cond := Parse_Expression; - - Alt_Label := Null_Identifier; - if Current_Token = Tok_Colon then - if Get_Kind (Cond) = Iir_Kind_Simple_Name then - if Vhdl_Std < Vhdl_08 then - Error_Msg_Parse - ("alternative label not allowed before vhdl08"); - end if; - - -- In fact the parsed condition was an alternate label. - Alt_Label := Get_Identifier (Cond); - Alt_Loc := Get_Location (Cond); - Free_Iir (Cond); - else - Error_Msg_Parse ("alternative label must be an identifier"); - Free_Iir (Cond); - end if; - - -- Skip ':' - Scan; - - Cond := Parse_Expression; - end if; - - Set_Condition (Clause, Cond); - - -- Skip 'generate' - Generate_Loc := Get_Token_Location; - Expect_Scan (Tok_Generate); - - Parse_Generate_Statement_Body (Res, Alt_Label, Bod, End_Loc); - - if Alt_Label /= Null_Identifier then - -- Set location on the label, for xrefs. - Set_Location (Bod, Alt_Loc); - end if; - - Set_Generate_Statement_Body (Clause, Bod); - - -- Append clause to the generate statement. - if Last /= Null_Iir then - Set_Generate_Else_Clause (Last, Clause); - end if; - Last := Clause; - - if Flag_Elocations then - Create_Elocations (Clause); - Set_Start_Location (Clause, Start_Loc); - Set_Generate_Location (Clause, Generate_Loc); - Set_End_Location (Clause, End_Loc); - end if; - - exit when Current_Token /= Tok_Elsif; - - -- Create new alternative. - Clause := Create_Iir (Iir_Kind_If_Generate_Statement); - Set_Location (Clause, Loc); - Start_Loc := Get_Token_Location; - - -- Skip 'elsif' - Scan; - end loop; - - if Current_Token = Tok_Else then - if Vhdl_Std < Vhdl_08 then - Error_Msg_Parse ("else generate not allowed before vhdl08"); - end if; - - Clause := Create_Iir (Iir_Kind_If_Generate_Else_Clause); - Start_Loc := Get_Token_Location; - Set_Location (Clause, Start_Loc); - - -- Skip 'else' - Scan; - - if Current_Token = Tok_Identifier then - Alt_Label := Current_Identifier; - Alt_Loc := Get_Token_Location; - - -- Skip identifier - Scan; - - -- Skip ':' - Expect_Scan (Tok_Colon); - else - Alt_Label := Null_Identifier; - end if; - - -- Skip 'generate' - Generate_Loc := Get_Token_Location; - Expect_Scan (Tok_Generate); - - Parse_Generate_Statement_Body (Res, Alt_Label, Bod, End_Loc); - if Alt_Label /= Null_Identifier then - -- Set location on the label, for xrefs. - Set_Location (Bod, Alt_Loc); - end if; - - Set_Generate_Statement_Body (Clause, Bod); - - Set_Generate_Else_Clause (Last, Clause); - - if Flag_Elocations then - Create_Elocations (Clause); - Set_Start_Location (Clause, Start_Loc); - Set_Generate_Location (Clause, Generate_Loc); - Set_End_Location (Clause, End_Loc); - end if; - end if; - - -- Skip 'generate' - Expect_Scan (Tok_Generate); - Set_End_Has_Reserved_Id (Res, True); - - -- LRM93 9.7 - -- If a label appears at the end of a generate statement, it must repeat - -- the generate label. - Check_End_Name (Res); - Expect_Scan (Tok_Semi_Colon); - return Res; - end Parse_If_Generate_Statement; - - -- precond : WHEN - -- postcond: ? - -- - -- [ LRM08 11.8 ] - -- case_generate_alternative ::= - -- WHEN [ /alternative/_label : ] choices => - -- generate_statement_body - procedure Parse_Case_Generate_Alternative (Parent : Iir; Assoc : out Iir) - is - Loc : Location_Type; - Alt_Label : Name_Id; - Bod : Iir; - Expr : Iir; - End_Loc : Location_Type; - begin - Loc := Get_Token_Location; - - -- Eat 'when' - Expect (Tok_When); - Scan; - - Alt_Label := Null_Identifier; - if Current_Token = Tok_Double_Arrow then - Error_Msg_Parse ("missing expression in alternative"); - Assoc := Create_Iir (Iir_Kind_Choice_By_Expression); - Set_Location (Assoc); - elsif Current_Token = Tok_Others then - -- 'others' is not an expression! - Parse_Choices (Null_Iir, Loc, Assoc); - else - Expr := Parse_Expression; - - if Current_Token = Tok_Colon then - if Get_Kind (Expr) = Iir_Kind_Simple_Name then - -- In fact the parsed condition was an alternate label. - Alt_Label := Get_Identifier (Expr); - Loc := Get_Location (Expr); - Free_Iir (Expr); - else - Error_Msg_Parse ("alternative label must be an identifier"); - Free_Iir (Expr); - end if; - - Expr := Null_Iir; - - -- Skip ':' - Scan; - end if; - - Parse_Choices (Expr, Loc, Assoc); - end if; - - -- Set location of label (if any, for xref) or location of 'when'. - Set_Location (Assoc, Loc); - - -- Eat '=>' - Expect_Scan (Tok_Double_Arrow); - - Parse_Generate_Statement_Body (Parent, Alt_Label, Bod, End_Loc); - Set_Associated_Block (Assoc, Bod); - if Alt_Label /= Null_Identifier then - -- Set location on the label, for xrefs. - Set_Location (Bod, Loc); - end if; - end Parse_Case_Generate_Alternative; - - -- precond : CASE - -- postcond: ';' - -- - -- [ LRM08 11.8 ] - -- case_generate_statement ::= - -- /generate/_label : - -- CASE expression GENERATE - -- case_generate_alternative - -- { case_generate_alternative } - -- END GENERATE [ /generate/_label ] ; - function Parse_Case_Generate_Statement - (Label : Name_Id; Loc : Location_Type) return Iir - is - Res : Iir; - Alt : Iir; - Last_Alt : Iir; - begin - if Label = Null_Identifier then - Error_Msg_Parse ("a generate statement must have a label"); - end if; - Res := Create_Iir (Iir_Kind_Case_Generate_Statement); - Set_Location (Res, Loc); - Set_Label (Res, Label); - - -- Skip 'case'. - Scan; - - Set_Expression (Res, Parse_Expression); - - -- Skip 'generate' - Expect_Scan (Tok_Generate); - - if Current_Token = Tok_End then - Error_Msg_Parse ("no generate alternative"); - end if; - - Last_Alt := Null_Iir; - while Current_Token = Tok_When loop - Parse_Case_Generate_Alternative (Res, Alt); - if Last_Alt = Null_Iir then - Set_Case_Statement_Alternative_Chain (Res, Alt); - else - Set_Chain (Last_Alt, Alt); - end if; - - -- Skip until last choice of the choices list. - loop - Last_Alt := Alt; - Alt := Get_Chain (Alt); - exit when Alt = Null_Iir; - end loop; - end loop; - - -- Skip 'generate' - Expect_Scan (Tok_Generate); - Set_End_Has_Reserved_Id (Res, True); - - -- LRM93 9.7 - -- If a label appears at the end of a generate statement, it must repeat - -- the generate label. - Check_End_Name (Res); - Expect_Scan (Tok_Semi_Colon); - - return Res; - end Parse_Case_Generate_Statement; - - -- precond : first token - -- postcond: next token - -- - -- [ LRM93 9.3 ] - -- concurrent_procedure_call_statement ::= - -- [ label : ] [ POSTPONED ] procedure_call ; - -- - -- [ LRM93 9.5 ] - -- concurrent_signal_assignment_statement ::= - -- [ label : ] [ POSTPONED ] conditional_signal_assignment - -- | [ label : ] [ POSTPONED ] selected_signal_assignment - function Parse_Concurrent_Assignment (Target : Iir) return Iir - is - Res : Iir; - begin - case Current_Token is - when Tok_Less_Equal - | Tok_Assign => - -- This is a conditional signal assignment. - -- Error for ':=' is handled by the subprogram. - return Parse_Concurrent_Conditional_Signal_Assignment (Target); - when Tok_Semi_Colon => - -- a procedure call or a component instantiation. - -- Parse it as a procedure call, may be revert to a - -- component instantiation during sem. - Res := Parenthesis_Name_To_Procedure_Call - (Target, Iir_Kind_Concurrent_Procedure_Call_Statement); - - -- Skip ';'. - Scan; - - return Res; - when Tok_Generic | Tok_Port => - -- or a component instantiation. - return Parse_Component_Instantiation (Target); - when others => - -- Catch PSL clock declaration. Within comments, this is the - -- right place (and handled as a concurrent statement). After - -- vhdl08, it is a declaration. - if Get_Kind (Target) = Iir_Kind_Simple_Name - and then Get_Identifier (Target) = Name_Default - and then Current_Token = Tok_Identifier - and then Current_Identifier = Name_Clock - then - Error_Msg_Parse (+Target, "PSL default clock is a declaration"); - - Current_Token := Tok_Psl_Clock; - Res := Parse_Psl_Default_Clock_Cont (Get_Location (Target)); - - return Res; - end if; - - -- or a simple simultaneous statement - if AMS_Vhdl then - Res := Create_Iir (Iir_Kind_Simple_Simultaneous_Statement); - Set_Simultaneous_Left - (Res, Parse_Binary_Expression (Target, Prio_Simple)); - if Current_Token /= Tok_Equal_Equal then - Error_Msg_Parse ("'==' expected after expression"); - else - Set_Location (Res); - Scan; - end if; - Set_Simultaneous_Right (Res, Parse_Expression (Prio_Simple)); - Set_Tolerance (Res, Parse_Tolerance_Aspect_Opt); - Expect_Scan (Tok_Semi_Colon); - return Res; - else - return Parse_Concurrent_Conditional_Signal_Assignment - (Parse_Binary_Expression (Target, Prio_Simple)); - end if; - end case; - end Parse_Concurrent_Assignment; - - -- Parse end of PSL assert/cover statement. - procedure Parse_Psl_Assert_Report_Severity (Stmt : Iir) is - begin - -- No more PSL tokens after the property. - Vhdl.Scanner.Flag_Psl := False; - - if Current_Token = Tok_Report then - -- Skip 'report' - Scan; - - Set_Report_Expression (Stmt, Parse_Expression); - end if; - - if Current_Token = Tok_Severity then - -- Skip 'severity' - Scan; - - Set_Severity_Expression (Stmt, Parse_Expression); - end if; - - Vhdl.Scanner.Flag_Scan_In_Comment := False; - - Expect_Scan (Tok_Semi_Colon); - end Parse_Psl_Assert_Report_Severity; - - function Parse_Psl_Assert_Statement return Iir - is - Res : Iir; - begin - Res := Create_Iir (Iir_Kind_Psl_Assert_Statement); - - -- Accept PSL tokens - if Flags.Vhdl_Std >= Vhdl_08 then - Vhdl.Scanner.Flag_Psl := True; - end if; - - -- Skip 'assert' - Scan; - - Set_Psl_Property (Res, Parse_Psl.Parse_Psl_Property); - - Parse_Psl_Assert_Report_Severity (Res); - - return Res; - end Parse_Psl_Assert_Statement; - - function Parse_Psl_Cover_Statement return Iir - is - Res : Iir; - begin - Res := Create_Iir (Iir_Kind_Psl_Cover_Statement); - - -- Skip 'cover' - Scan; - - Set_Psl_Sequence (Res, Parse_Psl.Parse_Psl_Sequence (True)); - - Parse_Psl_Assert_Report_Severity (Res); - - return Res; - end Parse_Psl_Cover_Statement; - - -- precond : first token - -- postcond: next token (end/else/when...) - -- - -- [ LRM93 9 ] - -- concurrent_statement ::= block_statement - -- | process_statement - -- | concurrent_procedure_call_statement - -- | concurrent_assertion_statement - -- | concurrent_signal_assignment_statement - -- | component_instantiation_statement - -- | generate_statement - -- - procedure Parse_Concurrent_Statements (Parent : Iir) - is - Last_Stmt : Iir; - Stmt: Iir; - Label: Name_Id; - Id: Iir; - Postponed : Boolean; - Loc : Location_Type; - Target : Iir; - - procedure Postponed_Not_Allowed is - begin - if Postponed then - Error_Msg_Parse ("'postponed' not allowed here"); - Postponed := False; - end if; - end Postponed_Not_Allowed; - - procedure Label_Not_Allowed is - begin - if Label /= Null_Identifier then - Error_Msg_Parse ("'postponed' not allowed here"); - Label := Null_Identifier; - end if; - end Label_Not_Allowed; - begin - -- begin was just parsed. - Last_Stmt := Null_Iir; - loop - Stmt := Null_Iir; - Label := Null_Identifier; - Postponed := False; - Loc := Get_Token_Location; - - -- Try to find a label. - if Current_Token = Tok_Identifier then - Label := Current_Identifier; - - -- Skip identifier - Scan; - - if Current_Token = Tok_Colon then - -- The identifier is really a label. - - -- Skip ':' - Scan; - else - -- This is not a label. Assume a concurrent assignment. - Target := Create_Iir (Iir_Kind_Simple_Name); - Set_Location (Target, Loc); - Set_Identifier (Target, Label); - Label := Null_Identifier; - Target := Parse_Name_Suffix (Target); - - Stmt := Parse_Concurrent_Assignment (Target); - goto Has_Stmt; - end if; - end if; - - if Current_Token = Tok_Postponed then - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse ("'postponed' is not allowed in vhdl 87"); - else - Postponed := True; - end if; - - -- Skip 'postponed' - Scan; - end if; - - case Current_Token is - when Tok_End | Tok_Else | Tok_Elsif | Tok_When => - -- End of list. 'else', 'elseif' and 'when' can be used to - -- separate statements in a generate statement. - Postponed_Not_Allowed; - if Label /= Null_Identifier then - Error_Msg_Parse ("label is not allowed here"); - end if; - return; - when Tok_Identifier => - Target := Parse_Name (Allow_Indexes => True); - Stmt := Parse_Concurrent_Assignment (Target); - if Get_Kind (Stmt) = Iir_Kind_Component_Instantiation_Statement - and then Postponed - then - Error_Msg_Parse ("'postponed' not allowed for " & - "an instantiation statement"); - Postponed := False; - end if; - when Tok_Left_Paren => - Id := Parse_Aggregate; - if Current_Token = Tok_Less_Equal then - -- This is a conditional signal assignment. - Stmt := Parse_Concurrent_Conditional_Signal_Assignment (Id); - else - Error_Msg_Parse ("'<=' expected after aggregate"); - Skip_Until_Semi_Colon; - end if; - when Tok_Process => - Stmt := Parse_Process_Statement (Label, Loc, Postponed); - when Tok_Assert => - if Vhdl_Std >= Vhdl_08 - or else (Flag_Psl_Comment and then Flag_Scan_In_Comment) - then - Stmt := Parse_Psl_Assert_Statement; - else - Stmt := Create_Iir (Iir_Kind_Concurrent_Assertion_Statement); - Parse_Assertion (Stmt); - Expect_Scan (Tok_Semi_Colon); - end if; - when Tok_With => - Stmt := Parse_Selected_Signal_Assignment; - when Tok_Block => - Postponed_Not_Allowed; - Stmt := Parse_Block_Statement (Label, Loc); - when Tok_For => - Postponed_Not_Allowed; - Stmt := Parse_For_Generate_Statement (Label, Loc); - when Tok_If => - Postponed_Not_Allowed; - Stmt := Parse_If_Generate_Statement (Label, Loc); - when Tok_Case => - Postponed_Not_Allowed; - Stmt := Parse_Case_Generate_Statement (Label, Loc); - when Tok_Eof => - Error_Msg_Parse ("unexpected end of file, 'END;' expected"); - return; - when Tok_Component - | Tok_Entity - | Tok_Configuration => - Postponed_Not_Allowed; - declare - Unit : Iir; - Has_Component : constant Boolean := - Current_Token = Tok_Component; - begin - Unit := Parse_Instantiated_Unit; - Stmt := Parse_Component_Instantiation (Unit); - Set_Has_Component (Stmt, Has_Component); - end; - when Tok_Psl_Default => - Postponed_Not_Allowed; - Label_Not_Allowed; - Stmt := Parse_Psl_Default_Clock; - when Tok_Psl_Property - | Tok_Psl_Sequence - | Tok_Psl_Endpoint => - Postponed_Not_Allowed; - Label_Not_Allowed; - Stmt := Parse_Psl_Declaration; - when Tok_Psl_Cover => - Postponed_Not_Allowed; - Stmt := Parse_Psl_Cover_Statement; - when Tok_Wait - | Tok_Loop - | Tok_While => - Error_Msg_Parse - ("sequential statement only allowed in processes"); - Stmt := Parse_Sequential_Statements (Parent); - Stmt := Null_Iir; - when others => - -- FIXME: improve message: - -- instead of 'unexpected token 'signal' in conc stmt list' - -- report: 'signal declarations are not allowed in conc stmt' - Unexpected ("concurrent statement list"); - Resync_To_End_Of_Statement; - if Current_Token = Tok_Semi_Colon then - Scan; - end if; - end case; - - << Has_Stmt >> null; - - -- Stmt can be null in case of error. - if Stmt /= Null_Iir then - Set_Location (Stmt, Loc); - if Label /= Null_Identifier then - Set_Label (Stmt, Label); - end if; - Set_Parent (Stmt, Parent); - if Postponed then - Set_Postponed_Flag (Stmt, True); - end if; - -- Append it to the chain. - if Last_Stmt = Null_Iir then - Set_Concurrent_Statement_Chain (Parent, Stmt); - else - Set_Chain (Last_Stmt, Stmt); - end if; - Last_Stmt := Stmt; - end if; - end loop; - end Parse_Concurrent_Statements; - - -- precond : LIBRARY - -- postcond: ; - -- - -- [ LRM93 11.2 ] - -- library_clause ::= LIBRARY logical_name_list - function Parse_Library_Clause return Iir - is - First, Last : Iir; - Library: Iir_Library_Clause; - Start_Loc : Location_Type; - begin - Sub_Chain_Init (First, Last); - Expect (Tok_Library); - loop - Library := Create_Iir (Iir_Kind_Library_Clause); - Start_Loc := Get_Token_Location; - Sub_Chain_Append (First, Last, Library); - - -- Skip 'library' or ','. - Scan; - - Scan_Identifier (Library); - - if Flag_Elocations then - Create_Elocations (Library); - Set_Start_Location (Library, Start_Loc); - end if; - - exit when Current_Token /= Tok_Comma; - - Set_Has_Identifier_List (Library, True); - end loop; - - -- Skip ';'. - Scan_Semi_Colon ("library clause"); - - return First; - end Parse_Library_Clause; - - -- precond : USE - -- postcond: next token (after ';'). - -- - -- [ LRM93 10.4 ] - -- use_clause ::= USE selected_name { , selected_name } - -- - -- FIXME: should be a list. - function Parse_Use_Clause return Iir_Use_Clause - is - Use_Clause: Iir_Use_Clause; - Loc : Location_Type; - First, Last : Iir; - begin - First := Null_Iir; - Last := Null_Iir; - - Loc := Get_Token_Location; - - -- Skip 'use'. - Scan; - - loop - Use_Clause := Create_Iir (Iir_Kind_Use_Clause); - Set_Location (Use_Clause, Loc); - Expect (Tok_Identifier); - Set_Selected_Name (Use_Clause, Parse_Name); - - -- Chain use clauses. - if First = Null_Iir then - First := Use_Clause; - else - Set_Use_Clause_Chain (Last, Use_Clause); - end if; - Last := Use_Clause; - - exit when Current_Token /= Tok_Comma; - Loc := Get_Token_Location; - - -- Skip ','. - Scan; - end loop; - - -- Skip ';'. - Scan_Semi_Colon ("use clause"); - - return First; - end Parse_Use_Clause; - - -- precond : ARCHITECTURE - -- postcond: ';'. - -- - -- [ LRM93 1.2 ] - -- architecture_body ::= - -- ARCHITECTURE identifier OF ENTITY_name IS - -- architecture_declarative_part - -- BEGIN - -- architecture_statement_part - -- END [ ARCHITECTURE ] [ ARCHITECTURE_simple_name ] ; - procedure Parse_Architecture_Body (Unit : Iir_Design_Unit) - is - Res : Iir_Architecture_Body; - Start_Loc : Location_Type; - Begin_Loc : Location_Type; - End_Loc : Location_Type; - begin - Expect (Tok_Architecture); - Res := Create_Iir (Iir_Kind_Architecture_Body); - Start_Loc := Get_Token_Location; - - -- Skip 'architecture'. - Scan; - - -- Identifier. - Scan_Identifier (Res); - - -- Skip 'of'. - Expect_Scan (Tok_Of); - - Set_Entity_Name (Res, Parse_Name (False)); - - -- Skip 'is'. - Expect_Scan (Tok_Is); - - Parse_Declarative_Part (Res); - - -- Skip 'begin'. - Begin_Loc := Get_Token_Location; - Expect_Scan (Tok_Begin); - - Parse_Concurrent_Statements (Res); - -- end was scanned. - End_Loc := Get_Token_Location; - - -- Skip 'end'. - Expect_Scan (Tok_End); - - if Current_Token = Tok_Architecture then - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse - ("'architecture' keyword not allowed here by vhdl 87"); - end if; - Set_End_Has_Reserved_Id (Res, True); - - -- Skip 'architecture'. - Scan; - end if; - Check_End_Name (Res); - Scan_Semi_Colon_Unit ("architecture"); - - Set_Library_Unit (Unit, Res); - - if Flag_Elocations then - Create_Elocations (Res); - Set_Start_Location (Res, Start_Loc); - Set_Begin_Location (Res, Begin_Loc); - Set_End_Location (Res, End_Loc); - end if; - end Parse_Architecture_Body; - - -- precond : next token - -- postcond: a token - -- - -- [ LRM93 5.2 ] - -- instantiation_list ::= INSTANTIATION_label { , INSTANTIATION_label } - -- | OTHERS - -- | ALL - -- - -- FIXME: merge with parse_signal_list ? - function Parse_Instantiation_List return Iir_Flist - is - Res : Iir_List; - begin - case Current_Token is - when Tok_All => - -- Skip 'all'. - Scan; - - return Iir_Flist_All; - - when Tok_Others => - -- Skip 'others'. - Scan; - - return Iir_Flist_Others; - - when Tok_Identifier => - Res := Create_Iir_List; - loop - Append_Element (Res, Current_Text); - -- Skip identifier. - Scan; - - exit when Current_Token /= Tok_Comma; - - -- Skip ','. - Scan; - - if Current_Token /= Tok_Identifier then - Expect (Tok_Identifier); - exit; - end if; - end loop; - return List_To_Flist (Res); - - when others => - Error_Msg_Parse ("instantiation list expected"); - return Null_Iir_Flist; - end case; - end Parse_Instantiation_List; - - -- precond : next token - -- postcond: next token - -- - -- [ LRM93 5.2 ] - -- component_specification ::= instantiation_list : COMPONENT_name - procedure Parse_Component_Specification (Res : Iir) - is - List : Iir_Flist; - begin - List := Parse_Instantiation_List; - Set_Instantiation_List (Res, List); - - -- Skip ':'. - Expect_Scan (Tok_Colon); - - Expect (Tok_Identifier); - Set_Component_Name (Res, Parse_Name); - end Parse_Component_Specification; - - -- precond : next token - -- postcond: next token - -- - -- [ LRM93 5.2.1.1 ] - -- entity_aspect ::= ENTITY ENTITY_name [ ( ARCHITECTURE_identifier ) ] - function Parse_Entity_Aspect_Entity return Iir - is - Res : Iir; - begin - Res := Create_Iir (Iir_Kind_Entity_Aspect_Entity); - Set_Location (Res); - - if Current_Token = Tok_Entity then - -- Eat 'entity' (but only if present). - Scan; - end if; - - Expect (Tok_Identifier); - Set_Entity_Name (Res, Parse_Name (False)); - - -- Optional architecture - if Current_Token = Tok_Left_Paren then - -- Skip '('. - Scan; - - if Current_Token = Tok_Identifier then - Set_Architecture (Res, Current_Text); - - -- Skip identifier. - Scan; - else - Expect (Tok_Identifier); - end if; - - Expect_Scan (Tok_Right_Paren); - end if; - - return Res; - end Parse_Entity_Aspect_Entity; - - -- precond : next token - -- postcond: next token - -- - -- [ LRM93 5.2.1.1 ] - -- entity_aspect ::= ENTITY ENTITY_name [ ( ARCHITECTURE_identifier ) ] - -- | CONFIGURATION CONFIGURATION_name - -- | OPEN - function Parse_Entity_Aspect return Iir - is - Res : Iir; - begin - case Current_Token is - when Tok_Entity => - Res := Parse_Entity_Aspect_Entity; - when Tok_Configuration => - Res := Create_Iir (Iir_Kind_Entity_Aspect_Configuration); - Set_Location (Res); - - -- Skip 'configuration'. - Scan; - - Expect (Tok_Identifier); - Set_Configuration_Name (Res, Parse_Name (False)); - when Tok_Open => - Res := Create_Iir (Iir_Kind_Entity_Aspect_Open); - Set_Location (Res); - Scan; - when others => - Error_Msg_Parse ("'entity', 'configuration' or 'open' expected"); - -- Assume 'entity' is missing (common case). - Res := Parse_Entity_Aspect_Entity; - end case; - return Res; - end Parse_Entity_Aspect; - - -- precond : next token - -- postcond: next token - -- - -- [ LRM93 5.2.1 ] - -- binding_indication ::= - -- [ USE entity_aspect ] - -- [ generic_map_aspect ] - -- [ port_map_aspect ] - function Parse_Binding_Indication return Iir_Binding_Indication - is - Res : Iir_Binding_Indication; - begin - case Current_Token is - when Tok_Use - | Tok_Generic - | Tok_Port => - null; - when others => - return Null_Iir; - end case; - Res := Create_Iir (Iir_Kind_Binding_Indication); - Set_Location (Res); - if Current_Token = Tok_Use then - Scan; - Set_Entity_Aspect (Res, Parse_Entity_Aspect); - end if; - if Current_Token = Tok_Generic then - Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect); - end if; - if Current_Token = Tok_Port then - Set_Port_Map_Aspect_Chain (Res, Parse_Port_Map_Aspect); - end if; - return Res; - end Parse_Binding_Indication; - - -- precond : ':' after instantiation_list. - -- postcond: next token. - -- - -- [ LRM93 1.3.2 ] - -- component_configuration ::= - -- FOR component_specification - -- [ binding_indication ; ] - -- [ block_configuration ] - -- END FOR ; - function Parse_Component_Configuration (Loc : Location_Type; - Inst_List : Iir_Flist) - return Iir_Component_Configuration - is - Res : Iir_Component_Configuration; - begin - Res := Create_Iir (Iir_Kind_Component_Configuration); - Set_Location (Res, Loc); - - -- Skip ':'. - pragma Assert (Current_Token = Tok_Colon); - Scan; - - -- Component specification. - Set_Instantiation_List (Res, Inst_List); - - Expect (Tok_Identifier); - Set_Component_Name (Res, Parse_Name); - - case Current_Token is - when Tok_Use - | Tok_Generic - | Tok_Port => - Set_Binding_Indication (Res, Parse_Binding_Indication); - Scan_Semi_Colon ("binding indication"); - when others => - null; - end case; - if Current_Token = Tok_For then - Set_Block_Configuration (Res, Parse_Block_Configuration); - end if; - Expect_Scan (Tok_End); - Expect_Scan (Tok_For); - Expect_Scan (Tok_Semi_Colon); - return Res; - end Parse_Component_Configuration; - - -- precond : FOR - -- postcond: next token. - -- - -- [ LRM93 1.3.1 ] - -- block_configuration ::= - -- FOR block_specification - -- { use_clause } - -- { configuration_item } - -- END FOR ; - -- - -- [ LRM93 1.3.1 ] - -- block_specification ::= - -- ARCHITECTURE_name - -- | BLOCK_STATEMENT_label - -- | GENERATE_STATEMENT_label [ ( index_specification ) ] - function Parse_Block_Configuration_Suffix (Loc : Location_Type; - Block_Spec : Iir) - return Iir - is - Res : Iir_Block_Configuration; - begin - Res := Create_Iir (Iir_Kind_Block_Configuration); - Set_Location (Res, Loc); - - Set_Block_Specification (Res, Block_Spec); - - -- Parse use clauses. - if Current_Token = Tok_Use then - declare - Last : Iir; - use Declaration_Chain_Handling; - begin - Build_Init (Last); - - while Current_Token = Tok_Use loop - Append_Subchain (Last, Res, Parse_Use_Clause); - end loop; - end; - end if; - - -- Parse configuration item list - declare - use Iir_Chains.Configuration_Item_Chain_Handling; - Last : Iir; - begin - Build_Init (Last); - while Current_Token = Tok_For loop - Append (Last, Res, Parse_Configuration_Item); - end loop; - end; - Expect_Scan (Tok_End); - Expect_Scan (Tok_For); - Expect_Scan (Tok_Semi_Colon); - return Res; - end Parse_Block_Configuration_Suffix; - - function Parse_Block_Configuration return Iir_Block_Configuration - is - Loc : Location_Type; - begin - Loc := Get_Token_Location; - - -- Skip 'for'. - Expect_Scan (Tok_For); - - return Parse_Block_Configuration_Suffix (Loc, Parse_Name); - end Parse_Block_Configuration; - - -- precond : FOR - -- postcond: next token. - -- - -- [ LRM93 1.3.1 ] - -- configuration_item ::= block_configuration - -- | component_configuration - function Parse_Configuration_Item return Iir - is - Loc : Location_Type; - List : Iir_List; - Flist : Iir_Flist; - El : Iir; - begin - Loc := Get_Token_Location; - Expect_Scan (Tok_For); - - -- ALL and OTHERS are tokens from an instantiation list. - -- Thus, the rule is a component_configuration. - case Current_Token is - when Tok_All => - -- Skip 'all'. - Scan; - - return Parse_Component_Configuration (Loc, Iir_Flist_All); - - when Tok_Others => - -- Skip 'others'. - Scan; - - return Parse_Component_Configuration (Loc, Iir_Flist_Others); - - when Tok_Identifier => - El := Current_Text; - - -- Skip identifier. - Scan; - - case Current_Token is - when Tok_Colon => - -- The identifier was a label from an instantiation list. - Flist := Create_Iir_Flist (1); - Set_Nth_Element (Flist, 0, El); - return Parse_Component_Configuration (Loc, Flist); - when Tok_Comma => - -- The identifier was a label from an instantiation list. - List := Create_Iir_List; - Append_Element (List, El); - while Current_Token = Tok_Comma loop - -- Skip ','. - Scan; - - if Current_Token = Tok_Identifier then - Append_Element (List, Current_Text); - - -- Skip identifier. - Scan; - else - Expect (Tok_Identifier); - exit; - end if; - end loop; - Flist := List_To_Flist (List); - return Parse_Component_Configuration (Loc, Flist); - when Tok_Left_Paren => - El := Parse_Name_Suffix (El); - return Parse_Block_Configuration_Suffix (Loc, El); - when Tok_Use | Tok_For | Tok_End => - -- Possibilities for a block_configuration. - -- FIXME: should use 'when others' ? - return Parse_Block_Configuration_Suffix (Loc, El); - when others => - Error_Msg_Parse - ("block_configuration or component_configuration " - & "expected"); - return Null_Iir; - end case; - when others => - Error_Msg_Parse ("configuration item expected"); - return Null_Iir; - end case; - end Parse_Configuration_Item; - - -- precond : next token - -- postcond: next token - -- - -- [ LRM93 1.3] - -- configuration_declarative_part ::= { configuration_declarative_item } - -- - -- [ LRM93 1.3] - -- configuration_declarative_item ::= use_clause - -- | attribute_specification - -- | group_declaration - -- FIXME: attribute_specification, group_declaration - procedure Parse_Configuration_Declarative_Part (Parent : Iir) - is - use Declaration_Chain_Handling; - Last : Iir; - El : Iir; - begin - Build_Init (Last); - loop - case Current_Token is - when Tok_Invalid => - raise Internal_Error; - when Tok_Use => - Append_Subchain (Last, Parent, Parse_Use_Clause); - when Tok_Attribute => - El := Parse_Attribute; - if El /= Null_Iir then - if Get_Kind (El) /= Iir_Kind_Attribute_Specification then - Error_Msg_Parse - ("attribute declaration not allowed here"); - end if; - Append (Last, Parent, El); - end if; - when Tok_Group => - El := Parse_Group; - if El /= Null_Iir then - if Get_Kind (El) /= Iir_Kind_Group_Declaration then - Error_Msg_Parse - ("group template declaration not allowed here"); - end if; - Append (Last, Parent, El); - end if; - when others => - exit; - end case; - end loop; - end Parse_Configuration_Declarative_Part; - - -- precond : CONFIGURATION - -- postcond: next token. - -- - -- [ LRM93 1.3 ] - -- configuration_declaration ::= - -- CONFIGURATION identifier OF ENTITY_name IS - -- configuration_declarative_part - -- block_configuration - -- END [ CONFIGURATION ] [ CONFIGURATION_simple_name ] ; - -- - -- [ LRM93 1.3 ] - -- configuration_declarative_part ::= { configuration_declarative_item } - procedure Parse_Configuration_Declaration (Unit : Iir_Design_Unit) - is - Res : Iir_Configuration_Declaration; - Start_Loc : Location_Type; - End_Loc : Location_Type; - begin - pragma Assert (Current_Token = Tok_Configuration); - Res := Create_Iir (Iir_Kind_Configuration_Declaration); - Start_Loc := Get_Token_Location; - - -- Skip 'configuration'. - pragma Assert (Current_Token = Tok_Configuration); - Scan; - - -- Get identifier. - Scan_Identifier (Res); - - -- Skip 'of'. - Expect_Scan (Tok_Of); - - Set_Entity_Name (Res, Parse_Name (False)); - - -- Skip 'is'. - Expect_Scan (Tok_Is); - - Parse_Configuration_Declarative_Part (Res); - - Set_Block_Configuration (Res, Parse_Block_Configuration); - - End_Loc := Get_Token_Location; - -- Skip 'end'. - Expect_Scan (Tok_End); - - if Current_Token = Tok_Configuration then - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse - ("'configuration' keyword not allowed here by vhdl 87"); - end if; - Set_End_Has_Reserved_Id (Res, True); - - -- Skip 'configuration'. - Scan; - end if; - - -- LRM93 1.3 - -- If a simple name appears at the end of a configuration declaration, - -- it must repeat the identifier of the configuration declaration. - Check_End_Name (Res); - Scan_Semi_Colon_Unit ("configuration"); - - Set_Library_Unit (Unit, Res); - - if Flag_Elocations then - Create_Elocations (Res); - Set_Start_Location (Res, Start_Loc); - Set_End_Location (Res, End_Loc); - end if; - end Parse_Configuration_Declaration; - - -- precond : generic - -- postcond: next token - -- - -- [ LRM08 4.7 ] - -- package_header ::= - -- [ generic_clause -- LRM08 6.5.6.2 - -- [ generic_map aspect ; ] ] - function Parse_Package_Header return Iir - is - Res : Iir; - begin - Res := Create_Iir (Iir_Kind_Package_Header); - Set_Location (Res); - Parse_Generic_Clause (Res); - - if Current_Token = Tok_Generic then - Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect); - Scan_Semi_Colon ("generic map aspect"); - end if; - return Res; - end Parse_Package_Header; - - -- precond : token (after 'IS') - -- postcond: next token. - -- - -- [ LRM93 2.5, LRM08 4.7 ] - -- package_declaration ::= - -- PACKAGE identifier IS - -- package_header -- LRM08 - -- package_declarative_part - -- END [ PACKAGE ] [ PACKAGE_simple_name ] ; - function Parse_Package_Declaration - (Parent : Iir; Id : Name_Id; Loc : Location_Type) return Iir - is - Res: Iir_Package_Declaration; - End_Loc : Location_Type; - begin - Res := Create_Iir (Iir_Kind_Package_Declaration); - Set_Location (Res, Loc); - Set_Identifier (Res, Id); - Set_Parent (Res, Parent); - - if Current_Token = Tok_Generic then - if Vhdl_Std < Vhdl_08 then - Error_Msg_Parse ("generic packages not allowed before vhdl 2008"); - end if; - Set_Package_Header (Res, Parse_Package_Header); - end if; - - Parse_Declarative_Part (Res); - - End_Loc := Get_Token_Location; - - -- Skip 'end' - Expect_Scan (Tok_End); - - if Current_Token = Tok_Package then - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse ("'package' keyword not allowed here by vhdl 87"); - end if; - Set_End_Has_Reserved_Id (Res, True); - - -- Skip 'package'. - Scan; - end if; - - Check_End_Name (Res); - Scan_Semi_Colon_Unit ("package declaration"); - - if Flag_Elocations then - Create_Elocations (Res); - Set_End_Location (Res, End_Loc); - end if; - - return Res; - end Parse_Package_Declaration; - - -- precond : BODY - -- postcond: next token. - -- - -- [ LRM93 2.6, LRM08 4.8 ] - -- package_body ::= - -- PACKAGE BODY PACKAGE_simple_name IS - -- package_body_declarative_part - -- END [ PACKAGE BODY ] [ PACKAGE_simple_name ] ; - function Parse_Package_Body (Parent : Iir) return Iir - is - Res : Iir; - End_Loc : Location_Type; - begin - Res := Create_Iir (Iir_Kind_Package_Body); - Set_Parent (Res, Parent); - - -- Get identifier. - Scan_Identifier (Res); - - -- Skip 'is'. - Expect_Scan (Tok_Is); - - Parse_Declarative_Part (Res); - - End_Loc := Get_Token_Location; - - -- Skip 'end' - Expect_Scan (Tok_End); - - if Current_Token = Tok_Package then - if Flags.Vhdl_Std = Vhdl_87 then - Error_Msg_Parse ("'package' keyword not allowed here by vhdl 87"); - end if; - Set_End_Has_Reserved_Id (Res, True); - - -- Skip 'package' - Scan; - - if Current_Token /= Tok_Body then - Error_Msg_Parse ("missing 'body' after 'package'"); - else - -- Skip 'body' - Scan; - end if; - end if; - - Check_End_Name (Res); - Scan_Semi_Colon_Unit ("package body"); - - if Flag_Elocations then - Create_Elocations (Res); - Set_End_Location (Res, End_Loc); - end if; - - return Res; - end Parse_Package_Body; - - -- precond : NEW - -- postcond: ';'. - -- - -- [ LRM08 4.9 ] - -- package_instantiation_declaration ::= - -- PACKAGE identifier IS NEW uninstantiated_package_name - -- [ generic_map_aspect ] ; - function Parse_Package_Instantiation_Declaration - (Parent : Iir; Id : Name_Id; Loc : Location_Type) return Iir - is - Res: Iir; - begin - Res := Create_Iir (Iir_Kind_Package_Instantiation_Declaration); - Set_Location (Res, Loc); - Set_Identifier (Res, Id); - Set_Parent (Res, Parent); - - -- Skip 'new' - Scan; - - Set_Uninstantiated_Package_Name (Res, Parse_Name (False)); - - if Current_Token = Tok_Generic then - Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect); - elsif Current_Token = Tok_Left_Paren then - Error_Msg_Parse ("missing 'generic map'"); - Set_Generic_Map_Aspect_Chain - (Res, Parse_Association_List_In_Parenthesis); - end if; - - if Flag_Elocations then - Create_Elocations (Res); - Set_End_Location (Res, Get_Token_Location); - end if; - - Scan_Semi_Colon_Unit ("package instantiation"); - - return Res; - end Parse_Package_Instantiation_Declaration; - - -- precond : PACKAGE - -- postcond: next token. - -- - -- package_declaration - -- | package_body - -- | package_instantiation_declaration - function Parse_Package (Parent : Iir) return Iir - is - Loc : Location_Type; - Id : Name_Id; - Res : Iir; - Start_Loc : Location_Type; - begin - -- Skip 'package' - Start_Loc := Get_Token_Location; - Scan; - - if Current_Token = Tok_Body then - -- Skip 'body' - Scan; - - Res := Parse_Package_Body (Parent); - else - Loc := Get_Token_Location; - if Current_Token = Tok_Identifier then - Id := Current_Identifier; - - -- Skip identifier. - Scan; - else - Expect (Tok_Identifier); - end if; - - -- Skip 'is'. - Expect_Scan (Tok_Is); - - if Current_Token = Tok_New then - Res := Parse_Package_Instantiation_Declaration (Parent, Id, Loc); - -- Note: there is no 'end' in instantiation. - else - Res := Parse_Package_Declaration (Parent, Id, Loc); - end if; - end if; - - if Flag_Elocations then - Set_Start_Location (Res, Start_Loc); - end if; - - return Res; - end Parse_Package; - - procedure Parse_Context_Declaration_Or_Reference - (Unit : Iir_Design_Unit; Clause : out Iir); - - -- Precond: next token - -- Postcond: next token - -- - -- [ LRM93 11.3, LRM08 13.4 Context clauses ] - -- context_clause ::= { context_item } - -- - -- context_item ::= library_clause | use_clause | context_reference - procedure Parse_Context_Clause (Unit : Iir) - is - use Context_Items_Chain_Handling; - Last : Iir; - Els : Iir; - begin - Build_Init (Last); - - loop - case Current_Token is - when Tok_Library => - Els := Parse_Library_Clause; - when Tok_Use => - Els := Parse_Use_Clause; - when Tok_Context => - Parse_Context_Declaration_Or_Reference (Unit, Els); - if Els = Null_Iir then - -- This was a context declaration. No more clause. - - -- LRM08 13.1 Design units - -- It is an error if the context clause preceding a library - -- unit that is a context declaration is not empty. - if Get_Context_Items (Unit) /= Null_Iir then - Error_Msg_Parse - (+Get_Context_Items (Unit), - "context declaration does not allow context " - & "clauses before it"); - end if; - - return; - end if; - when Tok_With => - -- Be Ada friendly. - Error_Msg_Parse ("'with' not allowed in context clause " - & "(try 'use' or 'library')"); - Els := Parse_Use_Clause; - when others => - exit; - end case; - Append_Subchain (Last, Unit, Els); - end loop; - end Parse_Context_Clause; - - -- Precond: IS - -- - -- [ LRM08 13.13 Context declarations ] - -- context_declaration ::= - -- CONTEXT identifier IS - -- context_clause - -- END [ CONTEXT ] [ /context/_simple_name ] ; - procedure Parse_Context_Declaration (Unit : Iir; Decl : Iir) - is - End_Loc : Location_Type; - begin - Set_Library_Unit (Unit, Decl); - - -- Skip 'is' - Scan; - - Parse_Context_Clause (Decl); - - Expect (Tok_End); - End_Loc := Get_Token_Location; - - -- Skip 'end' - Scan; - - if Current_Token = Tok_Context then - Set_End_Has_Reserved_Id (Decl, True); - - -- Skip 'context'. - Scan; - end if; - - Check_End_Name (Decl); - Scan_Semi_Colon_Unit ("context declaration"); - - if Flag_Elocations then - Create_Elocations (Decl); - Set_End_Location (Decl, End_Loc); - end if; - end Parse_Context_Declaration; - - -- Precond: next token after selected_name. - -- Postcond: next token - -- - -- [ LRM08 13.4 Context clauses ] - -- - -- context_reference ::= - -- CONTEXT selected_name { , selected_name } - function Parse_Context_Reference - (Loc : Location_Type; Name : Iir) return Iir - is - Ref : Iir; - First, Last : Iir; - begin - Ref := Create_Iir (Iir_Kind_Context_Reference); - Set_Location (Ref, Loc); - Set_Selected_Name (Ref, Name); - First := Ref; - Last := Ref; - - while Current_Token = Tok_Comma loop - -- Skip ','. - Scan; - - Ref := Create_Iir (Iir_Kind_Context_Reference); - Set_Location (Ref, Loc); - Set_Selected_Name (Ref, Parse_Name); - - Set_Context_Reference_Chain (Last, Ref); - Last := Ref; - end loop; - - Scan_Semi_Colon_Unit ("context reference"); - - return First; - end Parse_Context_Reference; - - -- Precond: CONTEXT - -- - procedure Parse_Context_Declaration_Or_Reference - (Unit : Iir_Design_Unit; Clause : out Iir) - is - Loc : Location_Type; - Name : Iir; - Res : Iir; - begin - Loc := Get_Token_Location; - - -- Skip 'context'. - Scan; - - Name := Parse_Name; - - if Current_Token = Tok_Is then - Res := Create_Iir (Iir_Kind_Context_Declaration); - if Get_Kind (Name) = Iir_Kind_Simple_Name then - Location_Copy (Res, Name); - Set_Identifier (Res, Get_Identifier (Name)); - else - Set_Location (Res, Loc); - Error_Msg_Parse (+Name, "identifier for context expected"); - end if; - Free_Iir (Name); - - Parse_Context_Declaration (Unit, Res); - Clause := Null_Iir; - else - Clause := Parse_Context_Reference (Loc, Name); - end if; - end Parse_Context_Declaration_Or_Reference; - - -- Parse a design_unit. - -- The lexical scanner must have been initialized, but without a - -- current_token. - -- - -- [ LRM93 11.1 ] - -- design_unit ::= context_clause library_unit - function Parse_Design_Unit return Iir_Design_Unit - is - procedure Error_Empty is - begin - Error_Msg_Parse - ("missing entity, architecture, package or configuration"); - end Error_Empty; - - Res: Iir_Design_Unit; - Unit: Iir; - begin - pragma Assert (Parenthesis_Depth = 0); - - -- Create the design unit node. - Res := Create_Iir (Iir_Kind_Design_Unit); - Set_Location (Res); - Set_Date_State (Res, Date_Extern); - - Parse_Context_Clause (Res); - - if Get_Library_Unit (Res) = Null_Iir then - -- Parse library unit. Context declaration are already parsed. - case Current_Token is - when Tok_Entity => - Parse_Entity_Declaration (Res); - when Tok_Architecture => - Parse_Architecture_Body (Res); - when Tok_Package => - Set_Library_Unit (Res, Parse_Package (Res)); - when Tok_Configuration => - Parse_Configuration_Declaration (Res); - when Tok_Identifier => - if Current_Identifier = Name_Context then - Error_Msg_Parse - ("context clause not allowed before vhdl 08"); - else - Error_Empty; - end if; - Resync_To_Next_Unit; - return Res; - when others => - Error_Empty; - Resync_To_Next_Unit; - return Res; - end case; - end if; - - Unit := Get_Library_Unit (Res); - Set_Design_Unit (Unit, Res); - Set_Identifier (Res, Get_Identifier (Unit)); - Set_Date (Res, Date_Parsed); - return Res; - end Parse_Design_Unit; - - -- [ LRM93 11.1 ] - -- design_file ::= design_unit { design_unit } - function Parse_Design_File return Iir_Design_File - is - Res : Iir_Design_File; - Design, Last_Design : Iir_Design_Unit; - begin - -- The first token. - pragma Assert (Current_Token = Tok_Invalid); - Scan; - - Res := Create_Iir (Iir_Kind_Design_File); - Set_Location (Res); - - Last_Design := Null_Iir; - while Current_Token /= Tok_Eof loop - Design := Parse_Design_Unit; - Set_Design_File (Design, Res); - - -- Append unit to the design file. - if Last_Design = Null_Iir then - Set_First_Design_Unit (Res, Design); - else - Set_Chain (Last_Design, Design); - end if; - Last_Design := Design; - Set_Last_Design_Unit (Res, Last_Design); - end loop; - - if Last_Design = Null_Iir then - Error_Msg_Parse ("design file is empty (no design unit found)"); - end if; - - return Res; - end Parse_Design_File; -end Parse; diff --git a/src/vhdl/parse.ads b/src/vhdl/parse.ads deleted file mode 100644 index 8204a2d0e..000000000 --- a/src/vhdl/parse.ads +++ /dev/null @@ -1,63 +0,0 @@ --- VHDL parser. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Types; use Types; -with Iirs; use Iirs; - -package Parse is - -- If True, create nodes for parenthesis expressions. - Flag_Parse_Parenthesis : Boolean := False; - - type Prio_Type is - ( - Prio_Expression, - Prio_Logical, - Prio_Relation, - Prio_Shift, - Prio_Simple, - Prio_Term, - Prio_Factor - ); - - -- Parse an expression. - -- (Used by PSL). - function Parse_Expression (Prio : Prio_Type := Prio_Expression) return Iir; - function Parse_Binary_Expression (Left : Iir; Prio : Prio_Type) return Iir; - - -- Convert the STR (0 .. LEN - 1) into a operator symbol identifier. - -- Emit an error message if the name is not an operator name. - function Str_To_Operator_Name (Str_Id : String8_Id; - Len : Nat32; - Loc : Location_Type) return Name_Id; - - -- Convert string literal STR to an operator symbol. - -- Emit an error message if the string is not an operator name. - function String_To_Operator_Symbol (Str : Iir) return Iir; - - -- Parse a single design unit. - -- The scanner must have been initialized, however, the current_token - -- shouldn't have been set. - -- At return, the last token accepted is the semi_colon that terminates - -- the library unit. - -- Return Null_Iir when end of file. - function Parse_Design_Unit return Iir_Design_Unit; - - -- Parse a file. - -- The scanner must have been initialized as for parse_design_unit. - -- Return Null_Iir in case of error. - function Parse_Design_File return Iir_Design_File; -end Parse; diff --git a/src/vhdl/parse_psl.adb b/src/vhdl/parse_psl.adb deleted file mode 100644 index 5d78efba6..000000000 --- a/src/vhdl/parse_psl.adb +++ /dev/null @@ -1,867 +0,0 @@ --- VHDL PSL parser. --- Copyright (C) 2009 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Errorout; use Errorout; -with PSL.Nodes; use PSL.Nodes; -with Iirs; -with Vhdl.Scanner; use Vhdl.Scanner; -with PSL.Errors; use PSL.Errors; -with PSL.Priorities; use PSL.Priorities; -with Parse; - -package body Parse_Psl is - procedure Error_Msg_Parse (Msg: String) is - begin - Report_Msg (Msgid_Error, Errorout.Parse, No_Location, Msg); - end Error_Msg_Parse; - - procedure Error_Msg_Parse - (Loc : Location_Type; Msg: String; Args : Earg_Arr := No_Eargs) is - begin - Report_Msg (Msgid_Error, Errorout.Parse, Loc, Msg, Args); - end Error_Msg_Parse; - - function Create_Node_Loc (K : Nkind) return Node is - Res : Node; - begin - Res := PSL.Nodes.Create_Node (K); - Set_Location (Res, Get_Token_Location); - return Res; - end Create_Node_Loc; - - function Parse_Number return Node is - Res : Node; - begin - if Current_Token = Tok_Integer then - Res := Create_Node_Loc (N_Number); - -- FIXME: handle overflow. - Set_Value (Res, Uns32 (Current_Iir_Int64)); - Scan; - return Res; - elsif Current_Token = Tok_Inf then - -- FIXME: create node - Scan; - return Null_Node; - else - Error_Msg_Parse ("number expected"); - return Null_Node; - end if; - end Parse_Number; - - procedure Parse_Count (N : Node) is - begin - Set_Low_Bound (N, Parse_Number); - if Current_Token = Tok_To then - Scan; - Set_High_Bound (N, Parse_Number); - end if; - end Parse_Count; - - function Psl_To_Vhdl (N : Node) return Iirs.Iir; - - function Binary_Psl_Operator_To_Vhdl (N : Node; Kind : Iirs.Iir_Kind) - return Iirs.Iir - is - use Iirs; - Res : Iir; - begin - Res := Create_Iir (Kind); - Set_Location (Res, Get_Location (N)); - Set_Left (Res, Psl_To_Vhdl (Get_Left (N))); - Set_Right (Res, Psl_To_Vhdl (Get_Right (N))); - return Res; - end Binary_Psl_Operator_To_Vhdl; - - function Psl_To_Vhdl (N : Node) return Iirs.Iir - is - use Iirs; - Res : Iir; - begin - case Get_Kind (N) is - when N_HDL_Expr => - Res := Iirs.Iir (Get_HDL_Node (N)); - when N_And_Prop => - Res := Binary_Psl_Operator_To_Vhdl (N, Iir_Kind_And_Operator); - when N_Or_Prop => - Res := Binary_Psl_Operator_To_Vhdl (N, Iir_Kind_Or_Operator); - when others => - Error_Msg_Parse - (+N, "PSL construct not allowed as VHDL expression"); - Res := Create_Iir (Iir_Kind_Error); - Set_Location (Res, Get_Location (N)); - end case; - Free_Node (N); - return Res; - end Psl_To_Vhdl; - - function Vhdl_To_Psl (N : Iirs.Iir) return Node - is - use Iirs; - Res : Node; - begin - Res := Create_Node_Loc (N_HDL_Expr); - if N /= Null_Iir then - Set_Location (Res, Get_Location (N)); - Set_HDL_Node (Res, Int32 (N)); - end if; - return Res; - end Vhdl_To_Psl; - - function Parse_FL_Property (Prio : Priority) return Node; - function Parse_Parenthesis_Boolean return Node; - function Parse_Boolean (Parent_Prio : Priority) return Node; - - function Parse_Unary_Boolean (Full_Hdl_Expr : Boolean) return Node - is - use Parse; - use Iirs; - Left, Expr : Iir; - Op : Iir_Kind; - begin - if Full_Hdl_Expr then - Expr := Parse_Expression; - else - -- Boolean operators must be parse, *except* and/or that could be at - -- upper layers (FL). - Expr := Parse_Expression (Prio_Relation); - loop - case Current_Token is - when Tok_Xor => - Op := Iir_Kind_Xor_Operator; - when Tok_Nand => - Op := Iir_Kind_Nand_Operator; - when Tok_Nor => - Op := Iir_Kind_Nor_Operator; - when Tok_Xnor => - Op := Iir_Kind_Xnor_Operator; - when others => - exit; - end case; - - Left := Expr; - Expr := Create_Iir (Op); - Set_Location (Expr, Get_Token_Location); - Set_Left (Expr, Left); - - -- Skip operator. - Scan; - - Set_Right (Expr, Parse_Expression (Prio_Relation)); - end loop; - end if; - - return Vhdl_To_Psl (Expr); - end Parse_Unary_Boolean; - - function Parse_Boolean_Rhs (Parent_Prio : Priority; Left : Node) return Node - is - Kind : Nkind; - Prio : Priority; - Res : Node; - Tmp : Node; - begin - Res := Left; - loop - case Current_Token is - when Tok_And => - Kind := N_And_Bool; - Prio := Prio_Seq_And; - when Tok_Or => - Kind := N_Or_Bool; - Prio := Prio_Seq_Or; - when others => - return Res; - end case; - if Parent_Prio >= Prio then - return Res; - end if; - Tmp := Create_Node_Loc (Kind); - Scan; - Set_Left (Tmp, Res); - Res := Tmp; - Tmp := Parse_Boolean (Prio); - Set_Right (Res, Tmp); - end loop; - end Parse_Boolean_Rhs; - - function Parse_Boolean (Parent_Prio : Priority) return Node - is - begin - return Parse_Boolean_Rhs (Parent_Prio, Parse_Unary_Boolean (False)); - end Parse_Boolean; - - function Parse_Psl_Boolean return PSL_Node is - begin - return Parse_Boolean (Prio_Lowest); - end Parse_Psl_Boolean; - - function Parse_Parenthesis_Boolean return Node is - Res : Node; - begin - if Current_Token /= Tok_Left_Paren then - Error_Msg_Parse ("'(' expected before boolean expression"); - return Null_Node; - else - Scan; - Res := Parse_Psl_Boolean; - if Current_Token = Tok_Right_Paren then - Scan; - else - Error_Msg_Parse ("missing matching ')' for boolean expression"); - end if; - return Res; - end if; - end Parse_Parenthesis_Boolean; - - function Parse_SERE (Prio : Priority) return Node is - Left, Res : Node; - Kind : Nkind; - Op_Prio : Priority; - begin - Left := Parse_Psl_Sequence (True); - loop - case Current_Token is - when Tok_Semi_Colon => - Kind := N_Concat_SERE; - Op_Prio := Prio_Seq_Concat; - when Tok_Colon => - Kind := N_Fusion_SERE; - Op_Prio := Prio_Seq_Fusion; - when Tok_Within => - Kind := N_Within_SERE; - Op_Prio := Prio_Seq_Within; - when Tok_Ampersand => - -- For non-length matching and, the operator is '&'. - Kind := N_And_Seq; - Op_Prio := Prio_Seq_And; - when Tok_And_And => - Kind := N_Match_And_Seq; - Op_Prio := Prio_Seq_And; - when Tok_Bar => - Kind := N_Or_Seq; - Op_Prio := Prio_Seq_Or; --- when Tok_Bar_Bar => --- Res := Create_Node_Loc (N_Or_Bool); --- Scan; --- Set_Left (Res, Left); --- Set_Right (Res, Parse_Boolean (Prio_Seq_Or)); --- return Res; - when others => - return Left; - end case; - if Prio >= Op_Prio then - return Left; - end if; - Res := Create_Node_Loc (Kind); - Scan; - Set_Left (Res, Left); - Set_Right (Res, Parse_SERE (Op_Prio)); - Left := Res; - end loop; - end Parse_SERE; - - -- precond : '{' - -- postcond: next token after '}' - function Parse_Braced_SERE return Node is - Res : Node; - begin - pragma Assert (Current_Token = Tok_Left_Curly); - Res := Create_Node_Loc (N_Braced_SERE); - - -- Skip '{' - Scan; - - Set_SERE (Res, Parse_SERE (Prio_Lowest)); - - if Current_Token /= Tok_Right_Curly then - Error_Msg_Parse ("missing '}' after braced SERE"); - else - -- Skip '}' - Scan; - end if; - return Res; - end Parse_Braced_SERE; - - -- Parse [ Count ] ']' - function Parse_Maybe_Count (Kind : Nkind; Seq : Node) return Node is - N : Node; - begin - N := Create_Node_Loc (Kind); - Set_Sequence (N, Seq); - Scan; - if Current_Token /= Tok_Right_Bracket then - Parse_Count (N); - end if; - if Current_Token /= Tok_Right_Bracket then - Error_Msg_Parse ("missing ']'"); - else - Scan; - end if; - return N; - end Parse_Maybe_Count; - - procedure Parse_Bracket_Range (N : Node) is - begin - if Current_Token /= Tok_Left_Bracket then - Error_Msg_Parse ("'[' expected"); - else - Scan; - Set_Low_Bound (N, Parse_Number); - if Current_Token /= Tok_To then - Error_Msg_Parse ("'to' expected in range after left bound"); - else - Scan; - Set_High_Bound (N, Parse_Number); - end if; - if Current_Token /= Tok_Right_Bracket then - Error_Msg_Parse ("']' expected after range"); - else - Scan; - end if; - end if; - end Parse_Bracket_Range; - - function Parse_Bracket_Number return Node is - Res : Node; - begin - if Current_Token /= Tok_Left_Bracket then - Error_Msg_Parse ("'[' expected"); - return Null_Node; - else - Scan; - Res := Parse_Number; - if Current_Token /= Tok_Right_Bracket then - Error_Msg_Parse ("']' expected after range"); - else - Scan; - end if; - return Res; - end if; - end Parse_Bracket_Number; - - function Parse_Psl_Sequence (Full_Hdl_Expr : Boolean) return Node is - Res, N : Node; - begin - case Current_Token is - when Tok_Left_Curly => - Res := Parse_Braced_SERE; - if Current_Token = Tok_Arobase then - N := Create_Node_Loc (N_Clocked_SERE); - Set_SERE (N, Res); - - -- Skip '@' - Scan; - - Set_Boolean (N, Parse_Psl_Boolean); - Res := N; - end if; - when Tok_Brack_Star => - return Parse_Maybe_Count (N_Star_Repeat_Seq, Null_Node); - when Tok_Left_Paren => - Res := Parse_Parenthesis_Boolean; - if Current_Token = Tok_Or - or else Current_Token = Tok_And - then - Res := Parse_Boolean_Rhs (Prio_Lowest, Res); - end if; - when Tok_Brack_Plus_Brack => - Res := Create_Node_Loc (N_Plus_Repeat_Seq); - Scan; - return Res; - when others => - -- Repeated_SERE - Res := Parse_Unary_Boolean (Full_Hdl_Expr); - end case; - loop - case Current_Token is - when Tok_Brack_Star => - Res := Parse_Maybe_Count (N_Star_Repeat_Seq, Res); - when Tok_Brack_Plus_Brack => - N := Create_Node_Loc (N_Plus_Repeat_Seq); - Set_Sequence (N, Res); - - -- Skip '[+]' - Scan; - Res := N; - when Tok_Brack_Arrow => - Res := Parse_Maybe_Count (N_Goto_Repeat_Seq, Res); - when Tok_Brack_Equal => - N := Create_Node_Loc (N_Equal_Repeat_Seq); - Set_Sequence (N, Res); - - -- Skip '[=' - Scan; - Parse_Count (N); - if Current_Token /= Tok_Right_Bracket then - Error_Msg_Parse ("missing ']'"); - else - Scan; - end if; - Res := N; - when others => - return Res; - end case; - end loop; - end Parse_Psl_Sequence; - - -- precond: '(' - -- postcond: next token - function Parse_Parenthesis_FL_Property return Node is - Res : Node; - Loc : Location_Type; - begin - Loc := Get_Token_Location; - if Current_Token /= Tok_Left_Paren then - Error_Msg_Parse ("'(' expected around property"); - return Parse_FL_Property (Prio_Lowest); - else - -- Skip '('. - Scan; - - Res := Parse_FL_Property (Prio_Lowest); - if Current_Token = Tok_Right_Paren then - -- Skip ')'. - Scan; - else - Error_Msg_Parse ("missing matching ')' for '(' at line " - & Image (Loc, False)); - end if; - - if Get_Kind (Res) = N_HDL_Expr then - declare - N : Iirs.Iir; - begin - N := Psl_To_Vhdl (Res); - N := Parse.Parse_Binary_Expression (N, Parse.Prio_Expression); - Res := Vhdl_To_Psl (N); - end; - end if; - return Res; - end if; - end Parse_Parenthesis_FL_Property; - - -- Parse [ '!' ] '[' finite_Range ']' '(' FL_Property ')' - function Parse_Range_Property (K : Nkind) return Node is - Res : Node; - begin - Res := Create_Node_Loc (K); - Set_Strong_Flag (Res, Scan_Exclam_Mark); - Scan; - Parse_Bracket_Range (Res); - Set_Property (Res, Parse_Parenthesis_FL_Property); - return Res; - end Parse_Range_Property; - - -- Parse [ '!' ] '(' Boolean ')' '[' Range ']' '(' FL_Property ')' - function Parse_Boolean_Range_Property (K : Nkind) return Node is - Res : Node; - begin - Res := Create_Node_Loc (K); - Set_Strong_Flag (Res, Scan_Exclam_Mark); - Scan; - Set_Boolean (Res, Parse_Parenthesis_Boolean); - Parse_Bracket_Range (Res); - Set_Property (Res, Parse_Parenthesis_FL_Property); - return Res; - end Parse_Boolean_Range_Property; - - function Parse_FL_Property_1 return Node - is - Res : Node; - Tmp : Node; - begin - case Current_Token is - when Tok_Always => - Res := Create_Node_Loc (N_Always); - Scan; - Set_Property (Res, Parse_FL_Property (Prio_FL_Invariance)); - when Tok_Never => - Res := Create_Node_Loc (N_Never); - Scan; - Set_Property (Res, Parse_FL_Property (Prio_FL_Invariance)); - when Tok_Eventually => - Res := Create_Node_Loc (N_Eventually); - if not Scan_Exclam_Mark then - Error_Msg_Parse ("'eventually' must be followed by '!'"); - end if; - Scan; - Set_Property (Res, Parse_FL_Property (Prio_FL_Occurence)); - when Tok_Next => - Res := Create_Node_Loc (N_Next); - Scan; - if Current_Token = Tok_Left_Bracket then - Set_Number (Res, Parse_Bracket_Number); - Set_Property (Res, Parse_Parenthesis_FL_Property); - else - Set_Property (Res, Parse_FL_Property (Prio_FL_Occurence)); - end if; - when Tok_Next_A => - Res := Parse_Range_Property (N_Next_A); - when Tok_Next_E => - Res := Parse_Range_Property (N_Next_E); - when Tok_Next_Event => - Res := Create_Node_Loc (N_Next_Event); - Scan; - Set_Boolean (Res, Parse_Parenthesis_Boolean); - if Current_Token = Tok_Left_Bracket then - Set_Number (Res, Parse_Bracket_Number); - end if; - Set_Property (Res, Parse_Parenthesis_FL_Property); - when Tok_Next_Event_A => - Res := Parse_Boolean_Range_Property (N_Next_Event_A); - when Tok_Next_Event_E => - Res := Parse_Boolean_Range_Property (N_Next_Event_E); - when Tok_Left_Paren => - return Parse_Parenthesis_FL_Property; - when Tok_Left_Curly => - Res := Parse_Psl_Sequence (True); - if Get_Kind (Res) = N_Braced_SERE - and then Current_Token = Tok_Left_Paren - then - -- FIXME: must check that RES is really a sequence - -- (and not a SERE). - Tmp := Create_Node_Loc (N_Overlap_Imp_Seq); - Set_Sequence (Tmp, Res); - Set_Property (Tmp, Parse_Parenthesis_FL_Property); - Res := Tmp; - end if; - when others => - Res := Parse_Psl_Sequence (False); - end case; - return Res; - end Parse_FL_Property_1; - - function Parse_St_Binary_FL_Property (K : Nkind; Left : Node) return Node is - Res : Node; - begin - Res := Create_Node_Loc (K); - Set_Strong_Flag (Res, Scan_Exclam_Mark); - Set_Inclusive_Flag (Res, Scan_Underscore); - Scan; - Set_Left (Res, Left); - Set_Right (Res, Parse_FL_Property (Prio_FL_Bounding)); - return Res; - end Parse_St_Binary_FL_Property; - - function Parse_Binary_FL_Property (K : Nkind; Left : Node; Prio : Priority) - return Node - is - Res : Node; - begin - Res := Create_Node_Loc (K); - Scan; - Set_Left (Res, Left); - Set_Right (Res, Parse_FL_Property (Prio)); - return Res; - end Parse_Binary_FL_Property; - - -- During LR parsing, phrases before |-> and |=> are parsed as properties, - -- but they are in fact sequences. Convert them (in particular the - -- boolean operators need to be rewritten). - function Property_To_Sequence (N : Node) return Node - is - procedure Rewrite_Binary (Res : Node; N : Node) is - begin - Set_Location (Res, Get_Location (N)); - Set_Left (Res, Property_To_Sequence (Get_Left (N))); - Set_Right (Res, Property_To_Sequence (Get_Right (N))); - Free_Node (N); - end Rewrite_Binary; - Res : Node; - begin - case Get_Kind (N) is - when N_And_Prop => - Res := Create_Node (N_And_Seq); - Rewrite_Binary (Res, N); - return Res; - when N_Or_Prop => - Res := Create_Node (N_Or_Seq); - Rewrite_Binary (Res, N); - return Res; - when N_Before => - Set_Left (N, Property_To_Sequence (Get_Left (N))); - Set_Right (N, Property_To_Sequence (Get_Right (N))); - return N; - when N_Clock_Event - | N_Always - | N_Never - | N_Eventually - | N_Until - | N_Property_Parameter - | N_Property_Instance - | N_Endpoint_Instance - | N_Strong - | N_Abort - | N_Next_Event_E - | N_Next_Event_A - | N_Next_Event - | N_Next_E - | N_Next_A - | N_Next - | N_Log_Imp_Prop => - Error_Msg_Parse (+N, "construct not allowed in sequences"); - return N; - when N_Const_Parameter - | N_Boolean_Parameter - | N_Sequence_Parameter - | N_Sequence_Instance - | N_Actual - | N_And_Seq - | N_Or_Seq - | N_Imp_Seq - | N_Overlap_Imp_Seq - | N_Match_And_Seq - | N_Star_Repeat_Seq - | N_Goto_Repeat_Seq - | N_Equal_Repeat_Seq - | N_Plus_Repeat_Seq - | N_Imp_Bool - | N_Or_Bool - | N_And_Bool - | N_Not_Bool - | N_Fusion_SERE - | N_HDL_Expr - | N_Hdl_Mod_Name - | N_Braced_SERE - | N_Concat_SERE - | N_Within_SERE - | N_Clocked_SERE - | N_False - | N_True - | N_Number - | N_Name_Decl - | N_Name - | N_EOS - | N_Error => - return N; - when N_Vmode - | N_Vunit - | N_Vprop - | N_Assert_Directive - | N_Property_Declaration - | N_Sequence_Declaration - | N_Endpoint_Declaration => - raise Internal_Error; - end case; - end Property_To_Sequence; - - function Parse_FL_Property (Prio : Priority) return Node - is - Res : Node; - N : Node; - begin - Res := Parse_FL_Property_1; - loop - case Current_Token is - when Tok_Minus_Greater => - if Prio > Prio_Bool_Imp then - return Res; - end if; - N := Create_Node_Loc (N_Log_Imp_Prop); - Set_Left (N, Res); - Scan; - Set_Right (N, Parse_FL_Property (Prio_Bool_Imp)); - Res := N; - when Tok_Bar_Arrow => - if Prio > Prio_Seq_Imp then - return Res; - end if; - N := Create_Node_Loc (N_Overlap_Imp_Seq); - Set_Sequence (N, Property_To_Sequence (Res)); - Scan; - Set_Property (N, Parse_FL_Property (Prio_Seq_Imp)); - Res := N; - when Tok_Bar_Double_Arrow => - if Prio > Prio_Seq_Imp then - return Res; - end if; - N := Create_Node_Loc (N_Imp_Seq); - Set_Sequence (N, Property_To_Sequence (Res)); - Scan; - Set_Property (N, Parse_FL_Property (Prio_Seq_Imp)); - Res := N; - when Tok_Abort => - if Prio > Prio_FL_Abort then - return Res; - end if; - N := Create_Node_Loc (N_Abort); - Set_Property (N, Res); - Scan; - Set_Boolean (N, Parse_Boolean (Prio_Lowest)); - -- Left associative. - return N; - when Tok_Exclam_Mark => - N := Create_Node_Loc (N_Strong); - Set_Property (N, Res); - Scan; - Res := N; - when Tok_Until => - if Prio > Prio_FL_Bounding then - return Res; - end if; - Res := Parse_St_Binary_FL_Property (N_Until, Res); - when Tok_Before => - if Prio > Prio_FL_Bounding then - return Res; - end if; - Res := Parse_St_Binary_FL_Property (N_Before, Res); - when Tok_Or => - if Prio > Prio_Seq_Or then - return Res; - end if; - Res := Parse_Binary_FL_Property (N_Or_Prop, Res, Prio_Seq_Or); - when Tok_And => - if Prio > Prio_Seq_And then - return Res; - end if; - Res := Parse_Binary_FL_Property (N_And_Prop, Res, Prio_Seq_And); - when Token_Relational_Operator_Type => - return Vhdl_To_Psl - (Parse.Parse_Binary_Expression - (Psl_To_Vhdl (Res), Parse.Prio_Relation)); - when Tok_Colon - | Tok_Bar - | Tok_Ampersand - | Tok_And_And => - Error_Msg_Parse ("SERE operator '" & Image (Current_Token) - & "' is not allowed in property"); - Scan; - N := Parse_FL_Property (Prio_Lowest); - return Res; - when Tok_Arobase => - if Prio > Prio_Clock_Event then - return Res; - end if; - N := Create_Node_Loc (N_Clock_Event); - Set_Property (N, Res); - Scan; - Set_Boolean (N, Parse_Boolean (Prio_Clock_Event)); - Res := N; - when others => - return Res; - end case; - end loop; - end Parse_FL_Property; - - function Parse_Psl_Property return PSL_Node is - begin - return Parse_FL_Property (Prio_Lowest); - end Parse_Psl_Property; - - -- precond: identifier - -- postcond: ';' - -- - -- 6.2.4.1 Property declaration - -- - -- Property_Declaration ::= - -- PROPERTY psl_identifier [ ( Formal_Parameter_List ) ] DEF_SYM - -- property ; - function Parse_Psl_Declaration (Tok : Token_Type) return PSL_Node - is - Res : Node; - Param : Node; - Last_Param : Node; - Pkind : Nkind; - Kind : Nkind; - begin - case Tok is - when Tok_Psl_Property => - Kind := N_Property_Declaration; - when Tok_Psl_Sequence => - Kind := N_Sequence_Declaration; - when Tok_Psl_Endpoint => - Kind := N_Endpoint_Declaration; - when others => - raise Internal_Error; - end case; - Res := Create_Node_Loc (Kind); - if Current_Token = Tok_Identifier then - Set_Identifier (Res, Current_Identifier); - Scan; - end if; - - -- Formal parameter list. - if Current_Token = Tok_Left_Paren then - Last_Param := Null_Node; - loop - -- precond: '(' or ';'. - Scan; - case Current_Token is - when Tok_Psl_Const => - Pkind := N_Const_Parameter; - when Tok_Psl_Boolean => - Pkind := N_Boolean_Parameter; - when Tok_Psl_Property => - Pkind := N_Property_Parameter; - when Tok_Psl_Sequence => - Pkind := N_Sequence_Parameter; - when others => - Error_Msg_Parse ("parameter type expected"); - end case; - - -- Formal parameters. - loop - -- precond: parameter_type or ',' - Scan; - Param := Create_Node_Loc (Pkind); - if Current_Token /= Tok_Identifier then - Error_Msg_Parse ("identifier for parameter expected"); - else - Set_Identifier (Param, Current_Identifier); - end if; - if Last_Param = Null_Node then - Set_Parameter_List (Res, Param); - else - Set_Chain (Last_Param, Param); - end if; - Last_Param := Param; - Scan; - exit when Current_Token /= Tok_Comma; - end loop; - exit when Current_Token = Tok_Right_Paren; - if Current_Token /= Tok_Semi_Colon then - Error_Msg_Parse ("';' expected between formal parameter"); - end if; - - end loop; - Scan; - end if; - - if Current_Token /= Tok_Is then - Error_Msg_Parse ("'is' expected after identifier"); - else - -- Skip 'is'. - Scan; - end if; - case Kind is - when N_Property_Declaration => - Set_Property (Res, Parse_Psl_Property); - when N_Sequence_Declaration - | N_Endpoint_Declaration => - Set_Sequence (Res, Parse_Psl_Sequence (True)); - when others => - raise Internal_Error; - end case; - return Res; - end Parse_Psl_Declaration; - - function Is_Instantiated_Declaration (N : PSL_Node) return Boolean is - begin - return Get_Parameter_List (N) = Null_Node; - end Is_Instantiated_Declaration; -end Parse_Psl; diff --git a/src/vhdl/parse_psl.ads b/src/vhdl/parse_psl.ads deleted file mode 100644 index c24e65091..000000000 --- a/src/vhdl/parse_psl.ads +++ /dev/null @@ -1,30 +0,0 @@ --- VHDL PSL parser. --- Copyright (C) 2009 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Types; use Types; -with Vhdl.Tokens; use Vhdl.Tokens; - -package Parse_Psl is - function Parse_Psl_Sequence (Full_Hdl_Expr : Boolean) return PSL_Node; - function Parse_Psl_Property return PSL_Node; - function Parse_Psl_Boolean return PSL_Node; - function Parse_Psl_Declaration (Tok : Token_Type) return PSL_Node; - - -- True if endpoint declaration N is instantiated (ie has no parameters). - function Is_Instantiated_Declaration (N : PSL_Node) return Boolean; -end Parse_Psl; diff --git a/src/vhdl/sem_assocs.adb b/src/vhdl/sem_assocs.adb index fe7f9542b..b04962c58 100644 --- a/src/vhdl/sem_assocs.adb +++ b/src/vhdl/sem_assocs.adb @@ -20,7 +20,7 @@ with Errorout; use Errorout; with Flags; use Flags; with Types; use Types; with Iirs_Utils; use Iirs_Utils; -with Parse; +with Vhdl.Parse; with Std_Names; with Sem_Names; use Sem_Names; with Sem_Types; @@ -83,7 +83,7 @@ package body Sem_Assocs is when Iir_Kinds_Interface_Subprogram_Declaration => N_Assoc := Create_Iir (Iir_Kind_Association_Element_Subprogram); if Get_Kind (Actual) = Iir_Kind_String_Literal8 then - Actual := Parse.String_To_Operator_Symbol (Actual); + Actual := Vhdl.Parse.String_To_Operator_Symbol (Actual); end if; when others => Error_Kind ("rewrite_non_object_association", Inter); diff --git a/src/vhdl/sem_lib.adb b/src/vhdl/sem_lib.adb index 6cf642f2f..afc54cbf3 100644 --- a/src/vhdl/sem_lib.adb +++ b/src/vhdl/sem_lib.adb @@ -22,7 +22,7 @@ with Iirs_Utils; use Iirs_Utils; with Errorout; use Errorout; with Libraries; use Libraries; with Vhdl.Scanner; -with Parse; +with Vhdl.Parse; with Disp_Tree; with Disp_Vhdl; with Sem; @@ -46,7 +46,7 @@ package body Sem_Lib is -- as an identifier, which is not valid at the beginning of a file. Res := Null_Iir; else - Res := Parse.Parse_Design_File; + Res := Vhdl.Parse.Parse_Design_File; end if; Vhdl.Scanner.Close_File; @@ -207,7 +207,7 @@ package body Sem_Lib is -- Parse Scan; - Res := Parse.Parse_Design_Unit; + Res := Vhdl.Parse.Parse_Design_Unit; Close_File; if Res = Null_Iir then raise Compilation_Error; diff --git a/src/vhdl/simulate/simul-debugger.adb b/src/vhdl/simulate/simul-debugger.adb index c257b909d..82eec793e 100644 --- a/src/vhdl/simulate/simul-debugger.adb +++ b/src/vhdl/simulate/simul-debugger.adb @@ -23,7 +23,7 @@ with Types; use Types; with Name_Table; with Str_Table; with Files_Map; -with Parse; +with Vhdl.Parse; with Vhdl.Scanner; with Vhdl.Tokens; with Sem_Expr; @@ -1337,7 +1337,8 @@ package body Simul.Debugger is Len := Len + 1; P := P + 1; end loop; - Break_Id := Parse.Str_To_Operator_Name (Str, Len, No_Location); + Break_Id := Vhdl.Parse.Str_To_Operator_Name + (Str, Len, No_Location); -- FIXME: free string. -- FIXME: catch error. end; @@ -1901,7 +1902,7 @@ package body Simul.Debugger is Line (P .. Line'Last)); Vhdl.Scanner.Set_File (File); Vhdl.Scanner.Scan; - Expr := Parse.Parse_Expression; + Expr := Vhdl.Parse.Parse_Expression; if Vhdl.Scanner.Current_Token /= Tok_Eof then Put_Line ("garbage at end of expression ignored"); end if; diff --git a/src/vhdl/vhdl-parse.adb b/src/vhdl/vhdl-parse.adb new file mode 100644 index 000000000..fc45ff965 --- /dev/null +++ b/src/vhdl/vhdl-parse.adb @@ -0,0 +1,9871 @@ +-- VHDL parser. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Iir_Chains; use Iir_Chains; +with Vhdl.Tokens; use Vhdl.Tokens; +with Vhdl.Scanner; use Vhdl.Scanner; +with Iirs_Utils; use Iirs_Utils; +with Errorout; use Errorout; +with Std_Names; use Std_Names; +with Flags; use Flags; +with Vhdl.Parse_Psl; +with Str_Table; +with Xrefs; +with Elocations; use Elocations; + +-- Recursive descendant parser. +-- Each subprogram (should) parse one production rules. +-- Rules are written in a comment just before the subprogram. +-- terminals are written in upper case. +-- non-terminal are written in lower case. +-- syntaxic category of a non-terminal are written in upper case. +-- eg: next_statement ::= [ label : ] NEXT [ LOOP_label ] [ WHEN condition ] ; +-- Or (|) must be aligned by the previous or, or with the '=' character. +-- Indentation is 4. +-- +-- To document what is expected for input and what is left as an output +-- concerning token stream, a precond and a postcond comment shoud be +-- added before the above rules. +-- a token (such as IF or ';') means the current token is this token. +-- 'a token' means the current token was analysed. +-- 'next token' means the current token is to be analysed. + +package body Vhdl.Parse is + + -- current_token must be valid. + -- Leaves a token. + function Parse_Primary return Iir_Expression; + function Parse_Use_Clause return Iir_Use_Clause; + + function Parse_Association_List return Iir; + function Parse_Association_List_In_Parenthesis return Iir; + + function Parse_Sequential_Statements (Parent : Iir) return Iir; + function Parse_Configuration_Item return Iir; + function Parse_Block_Configuration return Iir_Block_Configuration; + procedure Parse_Concurrent_Statements (Parent : Iir); + function Parse_Subprogram_Declaration return Iir; + function Parse_Subtype_Indication (Name : Iir := Null_Iir) return Iir; + function Parse_Interface_List (Ctxt : Interface_Kind_Type; Parent : Iir) + return Iir; + procedure Parse_Component_Specification (Res : Iir); + function Parse_Binding_Indication return Iir_Binding_Indication; + function Parse_Aggregate return Iir; + function Parse_Signature return Iir_Signature; + procedure Parse_Declarative_Part (Parent : Iir); + function Parse_Tolerance_Aspect_Opt return Iir; + function Parse_Package (Parent : Iir) return Iir; + + -- Maximum number of nested parenthesis, before generating an error. + Max_Parenthesis_Depth : constant Natural := 1000; + + -- Current number of open parenthesis (in expressions). + Parenthesis_Depth : Natural := 0; + + -- Copy the current location into an iir. + procedure Set_Location (Node : Iir) is + begin + Set_Location (Node, Get_Token_Location); + end Set_Location; + + -- Disp a message during parse + -- The location of the current token is automatically displayed before + -- the message. + procedure Error_Msg_Parse (Msg: String; Arg1 : Earg_Type) is + begin + Report_Msg (Msgid_Error, Errorout.Parse, No_Location, Msg, (1 => Arg1)); + end Error_Msg_Parse; + + procedure Error_Msg_Parse + (Msg: String; Args : Earg_Arr := No_Eargs; Cont : Boolean := False) is + begin + Report_Msg (Msgid_Error, Errorout.Parse, No_Location, Msg, Args, Cont); + end Error_Msg_Parse; + + procedure Error_Msg_Parse (Loc : Location_Type; + Msg: String; + Args : Earg_Arr := No_Eargs; + Cont : Boolean := False) is + begin + Report_Msg (Msgid_Error, Errorout.Parse, Loc, Msg, Args, Cont); + end Error_Msg_Parse; + + procedure Unexpected (Where: String) is + begin + Error_Msg_Parse ("unexpected token %t in a " & Where, +Current_Token); + end Unexpected; + + procedure Expect_Error (Token: Token_Type; Msg: String) + is + Loc : Location_Type; + begin + case Token is + when Tok_Semi_Colon + | Tok_Right_Paren + | Tok_Comma => + Loc := Get_Prev_Location; + when others => + Loc := Get_Token_Location; + end case; + + if Msg'Length > 0 then + Error_Msg_Parse (Loc, Msg, Args => No_Eargs, Cont => True); + Error_Msg_Parse (Loc, "(found: %t)", (1 => +Current_Token)); + elsif Current_Token = Tok_Identifier then + Error_Msg_Parse + (Loc, "%t is expected instead of %i", + (+Token, +Current_Identifier)); + else + Error_Msg_Parse + (Loc, "%t is expected instead of %t", (+Token, + Current_Token)); + end if; + end Expect_Error; + + -- Emit an error if the current_token if different from TOKEN. + -- Otherwise, accept the current_token (ie set it to tok_invalid, unless + -- TOKEN is Tok_Identifier). + procedure Expect (Token: Token_Type; Msg: String := "") is + begin + if Current_Token /= Token then + Expect_Error (Token, Msg); + end if; + end Expect; + + procedure Expect_Scan (Token: Token_Type; Msg: String := "") is + begin + if Current_Token = Token then + -- Skip token. + Scan; + else + Expect_Error (Token, Msg); + end if; + end Expect_Scan; + + -- Expect the identifier for node RES. + procedure Scan_Identifier (Res : Iir) is + begin + Set_Location (Res); + if Current_Token = Tok_Identifier then + Set_Identifier (Res, Current_Identifier); + + -- Skip identifier. + Scan; + else + Expect (Tok_Identifier); + end if; + end Scan_Identifier; + + -- If the current_token is an identifier, it must be equal to name. + -- In this case, a token is eaten. + -- If the current_token is not an identifier, this is a noop. + procedure Check_End_Name (Name : Name_Id; Decl : Iir) is + begin + if Current_Token /= Tok_Identifier then + return; + end if; + if Name = Null_Identifier then + Error_Msg_Parse + ("end label for an unlabeled declaration or statement"); + else + if Current_Identifier /= Name then + Error_Msg_Parse ("misspelling, %i expected", +Name); + else + Set_End_Has_Identifier (Decl, True); + Xrefs.Xref_End (Get_Token_Location, Decl); + end if; + end if; + + -- Skip identifier. + Scan; + end Check_End_Name; + + procedure Check_End_Name (Decl : Iir) is + begin + Check_End_Name (Get_Identifier (Decl), Decl); + end Check_End_Name; + + + -- Expect ' END tok [ name ] ; ' + procedure Check_End_Name (Tok : Token_Type; Decl : Iir) is + begin + if Current_Token /= Tok_End then + Error_Msg_Parse ("""end " & Image (Tok) & ";"" expected"); + else + Scan; + if Current_Token /= Tok then + Error_Msg_Parse ("""end"" must be followed by %t", +Tok); + else + Set_End_Has_Reserved_Id (Decl, True); + Scan; + end if; + Check_End_Name (Decl); + end if; + end Check_End_Name; + + procedure Skip_Until_Semi_Colon is + begin + loop + case Current_Token is + when Tok_Semi_Colon + | Tok_Eof => + exit; + when others => + Scan; + end case; + end loop; + end Skip_Until_Semi_Colon; + + procedure Resync_To_End_Of_Statement is + begin + loop + case Current_Token is + when Tok_Eof + | Tok_Semi_Colon + | Tok_End => + exit; + when Tok_If + | Tok_For + | Tok_While + | Tok_Loop + | Tok_Wait + | Tok_Assert => + -- Sequential statement. + exit; + when Tok_Process + | Tok_Block => + -- Concurrent statement. + exit; + when others => + Scan; + end case; + end loop; + end Resync_To_End_Of_Statement; + + procedure Resync_To_End_Of_Declaration is + begin + loop + case Current_Token is + when Tok_Eof => + exit; + when Tok_Semi_Colon => + Scan; + exit; + when Tok_End + | Tok_Begin => + -- End of current block. + exit; + when Tok_Signal + | Tok_Variable + | Tok_Constant + | Tok_File + | Tok_Alias + | Tok_Type + | Tok_Subtype + | Tok_Use + | Tok_Component + | Tok_Attribute + | Tok_Group + | Tok_For + | Tok_Disconnect + | Tok_Shared + | Tok_Impure + | Tok_Pure + | Tok_Function + | Tok_Procedure + | Tok_Package => + -- Start of a new declaration + exit; + when others => + -- Eat. + Scan; + end case; + end loop; + end Resync_To_End_Of_Declaration; + + procedure Resync_To_Next_Unit is + begin + -- Resync. + loop + case Current_Token is + when Tok_Eof => + exit; + when Tok_Semi_Colon => + -- Skip ';'. + Scan; + exit; + when Tok_Library + | Tok_Use + | Tok_Architecture + | Tok_Entity + | Tok_Package + | Tok_Configuration + | Tok_Context => + -- Possible start of a new unit. + exit; + when others => + Scan; + end case; + end loop; + end Resync_To_Next_Unit; + + procedure Skip_Until_Closing_Parenthesis + is + Level : Natural; + begin + Level := 0; + + -- Skip '('. + Scan; + + loop + case Current_Token is + when Tok_Right_Paren => + if Level = 0 then + -- Skip ')'. + Scan; + exit; + end if; + Level := Level - 1; + when Tok_Left_Paren => + Level := Level + 1; + when Tok_Eof + | Tok_Semi_Colon + | Tok_End + | Tok_Then + | Tok_Else + | Tok_Loop => + exit; + when others => + null; + end case; + + Scan; + end loop; + end Skip_Until_Closing_Parenthesis; + + -- Return True if at the end of the list, False if there is another + -- interface. + function Resync_To_End_Of_Interface return Boolean + is + Nested : Natural; + begin + Nested := 0; + loop + case Current_Token is + when Tok_End + | Tok_Port + | Tok_Is + | Tok_Begin + | Tok_Eof => + -- Certainly comes after interface list. + return True; + when Tok_Left_Paren => + Nested := Nested + 1; + when Tok_Right_Paren => + if Nested = 0 then + -- Skip ')'. + Scan; + + return True; + end if; + Nested := Nested - 1; + when Tok_Semi_Colon => + if Nested = 0 then + -- Skip ';'. + Scan; + + return False; + end if; + when Tok_Signal + | Tok_Variable + | Tok_Constant + | Tok_File + | Tok_Function + | Tok_Procedure + | Tok_Type + | Tok_Package => + -- Next interface ? + return False; + when Tok_Colon + | Tok_Identifier + | Tok_In + | Tok_Out + | Tok_Inout + | Tok_Buffer + | Tok_Linkage => + -- Certainly part of an interface. + null; + when others => + null; + end case; + + -- Skip token. + Scan; + end loop; + end Resync_To_End_Of_Interface; + + procedure Error_Missing_Semi_Colon (Msg : String) is + begin + Error_Msg_Parse (Get_Prev_Location, "missing "";"" at end of " & Msg); + end Error_Missing_Semi_Colon; + + -- Expect and scan ';' emit an error message using MSG if not present. + procedure Scan_Semi_Colon (Msg : String) is + begin + if Current_Token /= Tok_Semi_Colon then + Error_Missing_Semi_Colon (Msg); + else + Scan; + end if; + end Scan_Semi_Colon; + + procedure Scan_Semi_Colon_Declaration (Msg : String) is + begin + if Current_Token = Tok_Semi_Colon then + -- Skip ';'. + Scan; + else + Error_Missing_Semi_Colon (Msg); + + Resync_To_End_Of_Declaration; + end if; + end Scan_Semi_Colon_Declaration; + + procedure Scan_Semi_Colon_Unit (Msg : String) is + begin + if Current_Token = Tok_Semi_Colon then + -- Skip ';'. + Scan; + else + Error_Missing_Semi_Colon (Msg); + Resync_To_Next_Unit; + end if; + end Scan_Semi_Colon_Unit; + + function Create_Error_Node (Orig : Iir := Null_Iir) return Iir + is + Res : Iir; + begin + Res := Create_Error (Orig); + if Orig = Null_Iir then + Set_Location (Res); + end if; + return Res; + end Create_Error_Node; + + -- precond : next token + -- postcond: next token. + -- + -- [ LRM93 4.3.2 ] + -- mode ::= IN | OUT | INOUT | BUFFER | LINKAGE + -- + -- If there is no mode, DEFAULT is returned. + function Parse_Mode return Iir_Mode is + begin + case Current_Token is + when Tok_In => + Scan; + if Current_Token = Tok_Out then + -- Nice message for Ada users... + Error_Msg_Parse + ("typo error, 'in out' must be 'inout' in vhdl"); + Scan; + return Iir_Inout_Mode; + end if; + return Iir_In_Mode; + when Tok_Out => + Scan; + return Iir_Out_Mode; + when Tok_Inout => + Scan; + return Iir_Inout_Mode; + when Tok_Linkage => + Scan; + return Iir_Linkage_Mode; + when Tok_Buffer => + Scan; + return Iir_Buffer_Mode; + when others => + -- Cannot happen. + raise Internal_Error; + end case; + end Parse_Mode; + + -- precond : next token + -- postcond: next token + -- + -- [ LRM93 4.3.1.2 ] + -- signal_kind ::= REGISTER | BUS + -- + -- If there is no signal_kind, then no_signal_kind is returned. + procedure Parse_Signal_Kind + (Is_Guarded : out Boolean; Signal_Kind : out Iir_Signal_Kind) is + begin + if Current_Token = Tok_Bus then + -- Eat 'bus' + Scan; + + Is_Guarded := True; + Signal_Kind := Iir_Bus_Kind; + elsif Current_Token = Tok_Register then + -- Eat 'register' + Scan; + + Is_Guarded := True; + Signal_Kind := Iir_Register_Kind; + else + Is_Guarded := False; + -- Avoid uninitialized variable. + Signal_Kind := Iir_Bus_Kind; + end if; + end Parse_Signal_Kind; + + -- precond : TO, DOWNTO + -- postcond: next token + -- + -- Parse a range. + -- If LEFT is not null_iir, then it must be an expression corresponding to + -- the left limit of the range, and the current_token must be either + -- tok_to or tok_downto. + -- If left is null_iir, the current token is used to create the left limit + -- expression. + -- + -- [ LRM93 3.1 ] + -- range_constraint ::= RANGE range + -- + -- [ LRM93 3.1 ] + -- range ::= RANGE_attribute_name + -- | simple_expression direction simple_expression + -- + -- direction ::= TO | DOWNTO + function Parse_Range_Expression (Left : Iir) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Range_Expression); + + if Left /= Null_Iir then + Set_Left_Limit_Expr (Res, Left); + Location_Copy (Res, Left); + end if; + + case Current_Token is + when Tok_To => + Set_Direction (Res, Iir_To); + when Tok_Downto => + Set_Direction (Res, Iir_Downto); + when others => + raise Internal_Error; + end case; + + -- Skip 'to' or 'downto'. + Scan; + + Set_Right_Limit_Expr (Res, Parse_Expression (Prio_Simple)); + return Res; + end Parse_Range_Expression; + + -- precond: next token + -- postcond: next token + function Parse_Range return Iir + is + Left: Iir; + begin + Left := Parse_Expression (Prio_Simple); + + case Current_Token is + when Tok_To + | Tok_Downto => + return Parse_Range_Expression (Left); + when others => + if Left /= Null_Iir then + if Is_Range_Attribute_Name (Left) then + return Left; + end if; + Error_Msg_Parse ("'to' or 'downto' expected"); + end if; + return Create_Error_Node (Left); + end case; + end Parse_Range; + + -- precond: next token (after RANGE) + -- postcond: next token + function Parse_Range_Constraint return Iir is + begin + if Current_Token = Tok_Box then + Error_Msg_Parse ("range constraint required"); + Scan; + return Null_Iir; + end if; + + return Parse_Range; + end Parse_Range_Constraint; + + -- precond: next token (after RANGE) + -- postcond: next token + function Parse_Range_Constraint_Of_Subtype_Indication + (Type_Mark : Iir; + Resolution_Indication : Iir := Null_Iir) + return Iir + is + Def : Iir; + begin + Def := Create_Iir (Iir_Kind_Subtype_Definition); + if Type_Mark /= Null_Iir then + Location_Copy (Def, Type_Mark); + Set_Subtype_Type_Mark (Def, Type_Mark); + else + Set_Location (Def); + end if; + Set_Range_Constraint (Def, Parse_Range_Constraint); + Set_Resolution_Indication (Def, Resolution_Indication); + Set_Tolerance (Def, Parse_Tolerance_Aspect_Opt); + + return Def; + end Parse_Range_Constraint_Of_Subtype_Indication; + + -- precond: next token + -- postcond: next token + -- + -- [ LRM93 3.2.1 ] + -- discrete_range ::= discrete_subtype_indication | range + function Parse_Discrete_Range return Iir + is + Left: Iir; + begin + Left := Parse_Expression (Prio_Simple); + + case Current_Token is + when Tok_To + | Tok_Downto => + return Parse_Range_Expression (Left); + when Tok_Range => + return Parse_Subtype_Indication (Left); + when others => + -- Either a /range/_attribute_name or a type_mark. + return Left; + end case; + end Parse_Discrete_Range; + + -- Convert the STR (0 .. LEN - 1) into a operator symbol identifier. + -- Emit an error message if the name is not an operator name. + function Str_To_Operator_Name (Str_Id : String8_Id; + Len : Nat32; + Loc : Location_Type) return Name_Id + is + -- LRM93 2.1 + -- Extra spaces are not allowed in an operator symbol, and the + -- case of letters is not signifiant. + + -- LRM93 2.1 + -- The sequence of characters represented by an operator symbol + -- must be an operator belonging to one of classes of operators + -- defined in section 7.2. + + procedure Bad_Operator_Symbol is + begin + Error_Msg_Parse + (+Loc, "%s is not an operator symbol", (1 => +((Str_Id, Len)))); + end Bad_Operator_Symbol; + + procedure Check_Vhdl93 is + begin + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + (+Loc, "%s is not a vhdl87 operator symbol", + (1 => +((Str_Id, Len)))); + end if; + end Check_Vhdl93; + + Id : Name_Id; + C1, C2, C3, C4 : Character; + begin + C1 := Str_Table.Char_String8 (Str_Id, 1); + case Len is + when 1 => + -- =, <, >, +, -, *, /, & + case C1 is + when '=' => + Id := Name_Op_Equality; + when '>' => + Id := Name_Op_Greater; + when '<' => + Id := Name_Op_Less; + when '+' => + Id := Name_Op_Plus; + when '-' => + Id := Name_Op_Minus; + when '*' => + Id := Name_Op_Mul; + when '/' => + Id := Name_Op_Div; + when '&' => + Id := Name_Op_Concatenation; + when others => + Bad_Operator_Symbol; + Id := Name_Op_Plus; + end case; + when 2 => + -- or, /=, <=, >=, ** + C2 := Str_Table.Char_String8 (Str_Id, 2); + case C1 is + when 'o' | 'O' => + Id := Name_Or; + if C2 /= 'r' and C2 /= 'R' then + Bad_Operator_Symbol; + end if; + when '/' => + Id := Name_Op_Inequality; + if C2 /= '=' then + Bad_Operator_Symbol; + end if; + when '<' => + Id := Name_Op_Less_Equal; + if C2 /= '=' then + Bad_Operator_Symbol; + end if; + when '>' => + Id := Name_Op_Greater_Equal; + if C2 /= '=' then + Bad_Operator_Symbol; + end if; + when '*' => + Id := Name_Op_Exp; + if C2 /= '*' then + Bad_Operator_Symbol; + end if; + when '?' => + if Vhdl_Std < Vhdl_08 then + Bad_Operator_Symbol; + Id := Name_Op_Condition; + elsif C2 = '?' then + Id := Name_Op_Condition; + elsif C2 = '=' then + Id := Name_Op_Match_Equality; + elsif C2 = '<' then + Id := Name_Op_Match_Less; + elsif C2 = '>' then + Id := Name_Op_Match_Greater; + else + Bad_Operator_Symbol; + Id := Name_Op_Condition; + end if; + when others => + Bad_Operator_Symbol; + Id := Name_Op_Equality; + end case; + when 3 => + -- mod, rem, and, xor, nor, abs, not, sll, sla, sra, srl, rol + -- ror + C2 := Str_Table.Char_String8 (Str_Id, 2); + C3 := Str_Table.Char_String8 (Str_Id, 3); + case C1 is + when 'm' | 'M' => + Id := Name_Mod; + if (C2 /= 'o' and C2 /= 'O') or (C3 /= 'd' and C3 /= 'D') + then + Bad_Operator_Symbol; + end if; + when 'a' | 'A' => + if (C2 = 'n' or C2 = 'N') and (C3 = 'd' or C3 = 'D') then + Id := Name_And; + elsif (C2 = 'b' or C2 = 'B') and (C3 = 's' or C3 = 'S') then + Id := Name_Abs; + else + Id := Name_And; + Bad_Operator_Symbol; + end if; + when 'x' | 'X' => + Id := Name_Xor; + if (C2 /= 'o' and C2 /= 'O') or (C3 /= 'r' and C3 /= 'R') + then + Bad_Operator_Symbol; + end if; + when 'n' | 'N' => + if C2 = 'o' or C2 = 'O' then + if C3 = 'r' or C3 = 'R' then + Id := Name_Nor; + elsif C3 = 't' or C3 = 'T' then + Id := Name_Not; + else + Id := Name_Not; + Bad_Operator_Symbol; + end if; + else + Id := Name_Not; + Bad_Operator_Symbol; + end if; + when 's' | 'S' => + if C2 = 'l' or C2 = 'L' then + if C3 = 'l' or C3 = 'L' then + Check_Vhdl93; + Id := Name_Sll; + elsif C3 = 'a' or C3 = 'A' then + Check_Vhdl93; + Id := Name_Sla; + else + Id := Name_Sll; + Bad_Operator_Symbol; + end if; + elsif C2 = 'r' or C2 = 'R' then + if C3 = 'l' or C3 = 'L' then + Check_Vhdl93; + Id := Name_Srl; + elsif C3 = 'a' or C3 = 'A' then + Check_Vhdl93; + Id := Name_Sra; + else + Id := Name_Srl; + Bad_Operator_Symbol; + end if; + else + Id := Name_Sll; + Bad_Operator_Symbol; + end if; + when 'r' | 'R' => + if C2 = 'e' or C2 = 'E' then + if C3 = 'm' or C3 = 'M' then + Id := Name_Rem; + else + Id := Name_Rem; + Bad_Operator_Symbol; + end if; + elsif C2 = 'o' or C2 = 'O' then + if C3 = 'l' or C3 = 'L' then + Check_Vhdl93; + Id := Name_Rol; + elsif C3 = 'r' or C3 = 'R' then + Check_Vhdl93; + Id := Name_Ror; + else + Id := Name_Rol; + Bad_Operator_Symbol; + end if; + else + Id := Name_Rem; + Bad_Operator_Symbol; + end if; + when '?' => + if Vhdl_Std < Vhdl_08 then + Bad_Operator_Symbol; + Id := Name_Op_Match_Less_Equal; + else + if C2 = '<' and C3 = '=' then + Id := Name_Op_Match_Less_Equal; + elsif C2 = '>' and C3 = '=' then + Id := Name_Op_Match_Greater_Equal; + elsif C2 = '/' and C3 = '=' then + Id := Name_Op_Match_Inequality; + else + Bad_Operator_Symbol; + Id := Name_Op_Match_Less_Equal; + end if; + end if; + when others => + Id := Name_And; + Bad_Operator_Symbol; + end case; + when 4 => + -- nand, xnor + C2 := Str_Table.Char_String8 (Str_Id, 2); + C3 := Str_Table.Char_String8 (Str_Id, 3); + C4 := Str_Table.Char_String8 (Str_Id, 4); + if (C1 = 'n' or C1 = 'N') + and (C2 = 'a' or C2 = 'A') + and (C3 = 'n' or C3 = 'N') + and (C4 = 'd' or C4 = 'D') + then + Id := Name_Nand; + elsif (C1 = 'x' or C1 = 'X') + and (C2 = 'n' or C2 = 'N') + and (C3 = 'o' or C3 = 'O') + and (C4 = 'r' or C4 = 'R') + then + Check_Vhdl93; + Id := Name_Xnor; + else + Id := Name_Nand; + Bad_Operator_Symbol; + end if; + when others => + Id := Name_Op_Plus; + Bad_Operator_Symbol; + end case; + return Id; + end Str_To_Operator_Name; + + function Scan_To_Operator_Name (Loc : Location_Type) return Name_Id is + begin + return Str_To_Operator_Name + (Current_String_Id, Current_String_Length, Loc); + end Scan_To_Operator_Name; + pragma Inline (Scan_To_Operator_Name); + + -- Convert string literal STR to an operator symbol. + -- Emit an error message if the string is not an operator name. + function String_To_Operator_Symbol (Str : Iir) return Iir + is + Id : Name_Id; + Res : Iir; + begin + Id := Str_To_Operator_Name + (Get_String8_Id (Str), Get_String_Length (Str), Get_Location (Str)); + Res := Create_Iir (Iir_Kind_Operator_Symbol); + Location_Copy (Res, Str); + Set_Identifier (Res, Id); + Free_Iir (Str); + return Res; + end String_To_Operator_Symbol; + + -- precond : next token + -- postcond: next token + -- + -- [ LRM93 6.1 ] + -- name ::= simple_name + -- | operator_symbol + -- | selected_name + -- | indexed_name + -- | slice_name + -- | attribute_name + -- + -- [ LRM93 6.2 ] + -- simple_name ::= identifier + -- + -- [ LRM93 6.5 ] + -- slice_name ::= prefix ( discrete_range ) + -- + -- [ LRM93 6.3 ] + -- selected_name ::= prefix . suffix + -- + -- [ LRM93 6.1 ] + -- prefix ::= name + -- | function_call + -- + -- [ LRM93 6.3 ] + -- suffix ::= simple_name + -- | character_literal + -- | operator_symbol + -- | ALL + -- + -- [ LRM93 3.2.1 ] + -- discrete_range ::= DISCRETE_subtype_indication | range + -- + -- [ LRM93 3.1 ] + -- range ::= RANGE_attribute_name + -- | simple_expression direction simple_expression + -- + -- [ LRM93 3.1 ] + -- direction ::= TO | DOWNTO + -- + -- [ LRM93 6.6 ] + -- attribute_name ::= + -- prefix [ signature ] ' attribute_designator [ ( expression ) ] + -- + -- [ LRM93 6.6 ] + -- attribute_designator ::= ATTRIBUTE_simple_name + -- + -- Note: in order to simplify the parsing, this function may return a + -- signature without attribute designator. Signatures may appear at 3 + -- places: + -- - in attribute name + -- - in alias declaration + -- - in entity designator + function Parse_Name_Suffix (Pfx : Iir; + Allow_Indexes: Boolean := True; + Allow_Signature : Boolean := False) + return Iir + is + Res: Iir; + Prefix: Iir; + begin + Res := Pfx; + loop + Prefix := Res; + + case Current_Token is + when Tok_Left_Bracket => + if Get_Kind (Prefix) = Iir_Kind_String_Literal8 then + Prefix := String_To_Operator_Symbol (Prefix); + end if; + + -- There is a signature. They are normally followed by an + -- attribute. + Res := Parse_Signature; + Set_Signature_Prefix (Res, Prefix); + + when Tok_Tick => + -- There is an attribute. + if Get_Kind (Prefix) = Iir_Kind_String_Literal8 then + Prefix := String_To_Operator_Symbol (Prefix); + end if; + + -- Skip '''. + Scan; + + if Current_Token = Tok_Left_Paren then + -- A qualified expression. + Res := Create_Iir (Iir_Kind_Qualified_Expression); + Set_Type_Mark (Res, Prefix); + Location_Copy (Res, Prefix); + Set_Expression (Res, Parse_Aggregate); + return Res; + elsif Current_Token /= Tok_Range + and then Current_Token /= Tok_Identifier + and then not (Vhdl_Std >= Vhdl_08 + and then Current_Token = Tok_Subtype) + then + Expect + (Tok_Identifier, "attribute identifier expected after '"); + return Create_Error_Node (Prefix); + end if; + Res := Create_Iir (Iir_Kind_Attribute_Name); + Set_Identifier (Res, Current_Identifier); + Set_Location (Res); + if Get_Kind (Prefix) = Iir_Kind_Signature then + Set_Attribute_Signature (Res, Prefix); + + -- Transfer the prefix from the signature to the attribute. + Set_Prefix (Res, Get_Signature_Prefix (Prefix)); + Set_Signature_Prefix (Prefix, Null_Iir); + else + Set_Prefix (Res, Prefix); + end if; + + -- accept the identifier. + Scan; + + when Tok_Left_Paren => + if not Allow_Indexes then + return Res; + end if; + + if Get_Kind (Prefix) = Iir_Kind_String_Literal8 then + Prefix := String_To_Operator_Symbol (Prefix); + end if; + + Res := Create_Iir (Iir_Kind_Parenthesis_Name); + Set_Location (Res); + Set_Prefix (Res, Prefix); + Set_Association_Chain + (Res, Parse_Association_List_In_Parenthesis); + + when Tok_Dot => + if Get_Kind (Prefix) = Iir_Kind_String_Literal8 then + Prefix := String_To_Operator_Symbol (Prefix); + end if; + + -- Skip '.'. + Scan; + + case Current_Token is + when Tok_All => + Res := Create_Iir (Iir_Kind_Selected_By_All_Name); + Set_Location (Res); + Set_Prefix (Res, Prefix); + + -- Skip 'all'. + Scan; + + when Tok_Identifier + | Tok_Character => + Res := Create_Iir (Iir_Kind_Selected_Name); + Set_Location (Res); + Set_Prefix (Res, Prefix); + Set_Identifier (Res, Current_Identifier); + + -- Skip identifier/character. + Scan; + + when Tok_String => + Res := Create_Iir (Iir_Kind_Selected_Name); + Set_Location (Res); + Set_Prefix (Res, Prefix); + Set_Identifier + (Res, Scan_To_Operator_Name (Get_Token_Location)); + + -- Skip string. + Scan; + + when others => + Error_Msg_Parse + ("identifier or ""all"" is expected after '.'"); + Res := Prefix; + end case; + + when others => + if not Allow_Signature + and then Get_Kind (Res) = Iir_Kind_Signature + then + -- Not as a name. + Error_Msg_Parse ("signature name not expected here"); + Prefix := Get_Signature_Prefix (Res); + Set_Signature_Prefix (Res, Null_Iir); + Free_Iir (Res); + Res := Prefix; + end if; + return Res; + end case; + end loop; + end Parse_Name_Suffix; + + -- Precond: next token + -- Postcond: next token + -- + -- LRM08 8.7 External names + -- + -- external_pathname ::= + -- package_pathname + -- | absolute_pathname + -- | relative_pathname + -- + -- package_pathname ::= + -- @ library_logical_name . package_simple_name . + -- { package_simple_name . } object_simple_name + -- + -- absolute_pathname ::= + -- . partial_pathname + -- + -- relative_pathname ::= + -- { ^ . } partial_pathname + -- + -- partial_pathname ::= { pathname_element . } object_simple_name + -- + -- pathname_element ::= + -- entity_simple_name + -- | component_instantiation_label + -- | block_label + -- | generate_statement_label [ ( static_expression ) ] + -- | package_simple_name + function Parse_External_Pathname return Iir + is + Res : Iir; + Last : Iir; + El : Iir; + begin + case Current_Token is + when Tok_Arobase => + Res := Create_Iir (Iir_Kind_Package_Pathname); + Set_Location (Res); + Last := Res; + + -- Skip '@'. + Scan; + + if Current_Token /= Tok_Identifier then + Error_Msg_Parse ("library name expected after '@'"); + else + Set_Identifier (Res, Current_Identifier); + + -- Skip identifier. + Scan; + end if; + + if Current_Token /= Tok_Dot then + Error_Msg_Parse ("'.' expected after library name"); + else + -- Skip '.'. + Scan; + end if; + + when Tok_Dot => + Res := Create_Iir (Iir_Kind_Absolute_Pathname); + Set_Location (Res); + Last := Res; + + -- Skip '.'. + Scan; + + when Tok_Caret => + Last := Null_Iir; + loop + El := Create_Iir (Iir_Kind_Relative_Pathname); + Set_Location (El); + + -- Skip '^'. + Scan; + + if Current_Token /= Tok_Dot then + Error_Msg_Parse ("'.' expected after '^'"); + else + -- Skip '.'. + Scan; + end if; + + if Last = Null_Iir then + Res := El; + else + Set_Pathname_Suffix (Last, El); + end if; + Last := El; + + exit when Current_Token /= Tok_Caret; + end loop; + + when Tok_Identifier => + Last := Null_Iir; + + when others => + Last := Null_Iir; + -- Error is handled just below. + end case; + + -- Parse pathname elements. + loop + if Current_Token /= Tok_Identifier then + Error_Msg_Parse ("pathname element expected"); + -- FIXME: resync. + return Res; + end if; + + El := Create_Iir (Iir_Kind_Pathname_Element); + Set_Location (El); + Set_Identifier (El, Current_Identifier); + if Last = Null_Iir then + Res := El; + else + Set_Pathname_Suffix (Last, El); + end if; + Last := El; + + -- Skip identifier. + Scan; + + exit when Current_Token /= Tok_Dot; + + -- Skip '.'. + Scan; + end loop; + + return Res; + end Parse_External_Pathname; + + -- Precond: '<<' + -- Postcond: next token + -- + -- LRM08 8.7 External names + -- external_name ::= + -- external_constant_name + -- | external_signal_name + -- | external_variable_name + -- + -- external_constant_name ::= + -- << CONSTANT external_pathname : subtype_indication >> + -- + -- external_signal_name ::= + -- << SIGNAL external_pathname : subtype_indication >> + -- + -- external_variable_name ::= + -- << VARIABLE external_pathname : subtype_indication >> + function Parse_External_Name return Iir + is + Loc : Location_Type; + Res : Iir; + Kind : Iir_Kind; + begin + Loc := Get_Token_Location; + + -- Skip '<<'. + Scan; + + case Current_Token is + when Tok_Constant => + Kind := Iir_Kind_External_Constant_Name; + -- Skip 'constant'. + Scan; + when Tok_Signal => + Kind := Iir_Kind_External_Signal_Name; + -- Skip 'signal'. + Scan; + when Tok_Variable => + Kind := Iir_Kind_External_Variable_Name; + -- Skip 'variable'. + Scan; + when others => + Error_Msg_Parse + ("constant, signal or variable expected after '<<'"); + Kind := Iir_Kind_External_Signal_Name; + end case; + + Res := Create_Iir (Kind); + Set_Location (Res, Loc); + + Set_External_Pathname (Res, Parse_External_Pathname); + + if Current_Token /= Tok_Colon then + Error_Msg_Parse ("':' expected after external pathname"); + else + -- Skip ':' + Scan; + end if; + + Set_Subtype_Indication (Res, Parse_Subtype_Indication); + + if Current_Token /= Tok_Double_Greater then + Error_Msg_Parse ("'>>' expected at end of external name"); + else + -- Skip '>>' + Scan; + end if; + + return Res; + end Parse_External_Name; + + -- Precond: next token (identifier, string or '<<') + -- Postcond: next token + -- + -- LRM08 8. Names + -- name ::= + -- simple_name + -- | operator_symbol + -- | character_literal -- FIXME: not handled. + -- | selected_name + -- | indexed_name + -- | slice_name + -- | attribute_name + -- | external_name + function Parse_Any_Name + (Allow_Indexes: Boolean; Allow_Signature : Boolean) return Iir + is + Res: Iir; + begin + case Current_Token is + when Tok_Identifier => + Res := Create_Iir (Iir_Kind_Simple_Name); + Set_Identifier (Res, Current_Identifier); + Set_Location (Res); + + -- Skip identifier + Scan; + + when Tok_String => + -- For operator symbol, such as: "+" (A, B). + Res := Create_Iir (Iir_Kind_String_Literal8); + Set_String8_Id (Res, Current_String_Id); + Set_String_Length (Res, Current_String_Length); + Set_Location (Res); + + -- Skip string + Scan; + when Tok_Double_Less => + if Vhdl_Std < Vhdl_08 then + Error_Msg_Parse ("external name not allowed before vhdl 08"); + end if; + Res := Parse_External_Name; + when others => + if Current_Token = Tok_Invalid then + Error_Msg_Parse ("name expected here"); + else + Error_Msg_Parse + ("name expected here, found %t", +Current_Token); + end if; + return Create_Error_Node; + end case; + + return Parse_Name_Suffix (Res, Allow_Indexes, Allow_Signature); + end Parse_Any_Name; + + function Parse_Name (Allow_Indexes: Boolean := True) return Iir is + begin + return Parse_Any_Name (Allow_Indexes, False); + end Parse_Name; + + function Parse_Signature_Name return Iir is + begin + return Parse_Any_Name (True, True); + end Parse_Signature_Name; + + -- Emit an error message if MARK doesn't have the form of a type mark. + procedure Check_Type_Mark (Mark : Iir) is + begin + case Get_Kind (Mark) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + null; + when Iir_Kind_Attribute_Name => + -- For O'Subtype. + null; + when others => + Error_Msg_Parse (+Mark, "type mark must be a name of a type"); + end case; + end Check_Type_Mark; + + -- precond : next token + -- postcond: next token + -- + -- [ 4.2 ] + -- type_mark ::= type_name + -- | subtype_name + function Parse_Type_Mark (Check_Paren : Boolean := False) return Iir + is + Res : Iir; + Old : Iir; + pragma Unreferenced (Old); + begin + Res := Parse_Name (Allow_Indexes => False); + + Check_Type_Mark (Res); + if Check_Paren and then Current_Token = Tok_Left_Paren then + Error_Msg_Parse ("index constraint not allowed here"); + Old := Parse_Name_Suffix (Res, True); + end if; + return Res; + end Parse_Type_Mark; + + -- precond : CONSTANT, SIGNAL, VARIABLE. FILE or identifier + -- postcond: next token (';' or ')') + -- + -- [ LRM93 4.3.2 ] [ LRM08 6.5.2 ] + -- interface_declaration ::= interface_constant_declaration + -- | interface_signal_declaration + -- | interface_variable_declaration + -- | interface_file_declaration + -- + -- + -- [ LRM93 3.2.2 ] + -- identifier_list ::= identifier { , identifier } + -- + -- [ LRM93 4.3.2 ] + -- interface_constant_declaration ::= + -- [ CONSTANT ] identifier_list : [ IN ] subtype_indication + -- [ := STATIC_expression ] + -- + -- [ LRM93 4.3.2 ] + -- interface_file_declaration ::= FILE identifier_list : subtype_indication + -- + -- [ LRM93 4.3.2 ] + -- interface_signal_declaration ::= + -- [ SIGNAL ] identifier_list : [ mode ] subtype_indication [ BUS ] + -- [ := STATIC_expression ] + -- + -- [ LRM93 4.3.2 ] + -- interface_variable_declaration ::= + -- [ VARIABLE ] identifier_list : [ mode ] subtype_indication + -- [ := STATIC_expression ] + -- + -- The default kind of interface declaration is DEFAULT. + function Parse_Interface_Object_Declaration (Ctxt : Interface_Kind_Type) + return Iir + is + Kind : Iir_Kind; + Last : Iir; + First : Iir; + Inter: Iir; + Is_Default : Boolean; + Interface_Mode: Iir_Mode; + Interface_Type: Iir; + Is_Guarded : Boolean; + Signal_Kind: Iir_Signal_Kind; + Default_Value: Iir; + Has_Mode : Boolean; + Has_Class : Boolean; + begin + -- LRM08 6.5.2 Interface object declarations + -- Interface obejcts include interface constants that appear as + -- generics of a design entity, a component, a block, a package or + -- a subprogram, or as constant parameter of subprograms; interface + -- signals that appear as ports of a design entity, component or + -- block, or as signal parameters of subprograms; interface variables + -- that appear as variable parameter subprograms; interface files + -- that appear as file parameters of subrograms. + case Current_Token is + when Tok_Identifier => + -- The class of the object is unknown. Select default + -- according to the above rule, assuming the mode is IN. If + -- the mode is not IN, Parse_Interface_Object_Declaration will + -- change the class. + case Ctxt is + when Generic_Interface_List + | Parameter_Interface_List => + Kind := Iir_Kind_Interface_Constant_Declaration; + when Port_Interface_List => + Kind := Iir_Kind_Interface_Signal_Declaration; + end case; + when Tok_Constant => + Kind := Iir_Kind_Interface_Constant_Declaration; + when Tok_Signal => + if Ctxt = Generic_Interface_List then + Error_Msg_Parse + ("signal interface not allowed in generic clause"); + end if; + Kind := Iir_Kind_Interface_Signal_Declaration; + when Tok_Variable => + if Ctxt not in Parameter_Interface_List then + Error_Msg_Parse + ("variable interface not allowed in generic or port clause"); + end if; + Kind := Iir_Kind_Interface_Variable_Declaration; + when Tok_File => + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("file interface not allowed in vhdl 87"); + end if; + if Ctxt not in Parameter_Interface_List then + Error_Msg_Parse + ("variable interface not allowed in generic or port clause"); + end if; + Kind := Iir_Kind_Interface_File_Declaration; + when others => + -- Fall back in case of parse error. + Kind := Iir_Kind_Interface_Variable_Declaration; + end case; + + First := Create_Iir (Kind); + + if Flag_Elocations then + Create_Elocations (First); + Set_Start_Location (First, Get_Token_Location); + end if; + + if Current_Token = Tok_Identifier then + Is_Default := True; + Has_Class := False; + else + Is_Default := False; + Has_Class := True; + + -- Skip 'signal', 'variable', 'constant' or 'file'. + Scan; + end if; + + -- Parse list of identifiers. + Inter := First; + Last := First; + loop + Scan_Identifier (Inter); + + exit when Current_Token /= Tok_Comma; + + -- Skip ',' + Scan; + + Inter := Create_Iir (Kind); + + if Flag_Elocations then + Create_Elocations (Inter); + Set_Start_Location (Inter, Get_Start_Location (First)); + end if; + + Set_Chain (Last, Inter); + Last := Inter; + end loop; + + if Flag_Elocations then + Set_Colon_Location (First, Get_Token_Location); + end if; + + -- Skip ':' + Expect_Scan (Tok_Colon, "':' expected after interface identifier"); + + -- Parse mode. + case Current_Token is + when Tok_In + | Tok_Out + | Tok_Inout + | Tok_Linkage + | Tok_Buffer => + Interface_Mode := Parse_Mode; + Has_Mode := True; + when others => + Interface_Mode := Iir_Unknown_Mode; + Has_Mode := False; + end case; + + -- LRM93 2.1.1 LRM08 4.2.2.1 + -- If the mode is INOUT or OUT, and no object class is explicitly + -- specified, variable is assumed. + if Is_Default + and then Ctxt in Parameter_Interface_List + and then Interface_Mode in Iir_Out_Modes + then + -- Convert into variable. + declare + O_Interface : Iir_Interface_Constant_Declaration; + N_Interface : Iir_Interface_Variable_Declaration; + begin + O_Interface := First; + while O_Interface /= Null_Iir loop + N_Interface := + Create_Iir (Iir_Kind_Interface_Variable_Declaration); + Location_Copy (N_Interface, O_Interface); + Set_Identifier (N_Interface, Get_Identifier (O_Interface)); + + if Flag_Elocations then + Create_Elocations (N_Interface); + Set_Start_Location + (N_Interface, Get_Start_Location (O_Interface)); + Set_Colon_Location + (N_Interface, Get_Colon_Location (O_Interface)); + end if; + + if O_Interface = First then + First := N_Interface; + else + Set_Chain (Last, N_Interface); + end if; + Last := N_Interface; + + Inter := Get_Chain (O_Interface); + if Flag_Elocations then + Delete_Elocations (O_Interface); + end if; + Free_Iir (O_Interface); + O_Interface := Inter; + end loop; + Inter := First; + end; + end if; + + -- Parse mode (and handle default mode). + case Iir_Kinds_Interface_Object_Declaration (Get_Kind (Inter)) is + when Iir_Kind_Interface_File_Declaration => + if Interface_Mode /= Iir_Unknown_Mode then + Error_Msg_Parse + ("mode can't be specified for a file interface"); + end if; + Interface_Mode := Iir_Inout_Mode; + when Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_Variable_Declaration => + -- LRM93 4.3.2 + -- If no mode is explicitly given in an interface declaration + -- other than an interface file declaration, mode IN is + -- assumed. + if Interface_Mode = Iir_Unknown_Mode then + Interface_Mode := Iir_In_Mode; + end if; + when Iir_Kind_Interface_Constant_Declaration => + if Interface_Mode = Iir_Unknown_Mode then + Interface_Mode := Iir_In_Mode; + elsif Interface_Mode /= Iir_In_Mode then + Error_Msg_Parse ("mode must be 'in' for a constant"); + Interface_Mode := Iir_In_Mode; + end if; + end case; + + Interface_Type := Parse_Subtype_Indication; + + -- Signal kind (but only for signal). + if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then + Parse_Signal_Kind (Is_Guarded, Signal_Kind); + else + Is_Guarded := False; + Signal_Kind := Iir_Register_Kind; + end if; + + if Current_Token = Tok_Assign then + if Get_Kind (Inter) = Iir_Kind_Interface_File_Declaration then + Error_Msg_Parse + ("default expression not allowed for an interface file"); + end if; + + -- Skip ':=' + if Flag_Elocations then + Set_Assign_Location (First, Get_Token_Location); + end if; + Scan; + + Default_Value := Parse_Expression; + else + Default_Value := Null_Iir; + end if; + + -- Subtype_Indication and Default_Value are set only on the first + -- interface. + Set_Subtype_Indication (First, Interface_Type); + if Get_Kind (First) /= Iir_Kind_Interface_File_Declaration then + Set_Default_Value (First, Default_Value); + end if; + + Inter := First; + while Inter /= Null_Iir loop + Set_Mode (Inter, Interface_Mode); + Set_Is_Ref (Inter, Inter /= First); + Set_Has_Mode (Inter, Has_Mode); + Set_Has_Class (Inter, Has_Class); + Set_Has_Identifier_List (Inter, Inter /= Last); + if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then + Set_Guarded_Signal_Flag (Inter, Is_Guarded); + Set_Signal_Kind (Inter, Signal_Kind); + end if; + Inter := Get_Chain (Inter); + end loop; + + return First; + end Parse_Interface_Object_Declaration; + + -- Precond : 'package' + -- Postcond: next token + -- + -- LRM08 6.5.5 Interface package declarations + -- interface_package_declaration ::= + -- PACKAGE identifier IS NEW uninstantiated_package name + -- interface_package_generic_map_aspect + -- + -- interface_package_generic_map_aspect ::= + -- generic_map_aspect + -- | GENERIC MAP ( <> ) + -- | GENERIC MAP ( DEFAULT ) + function Parse_Interface_Package_Declaration return Iir + is + Inter : Iir; + Map : Iir; + begin + Inter := Create_Iir (Iir_Kind_Interface_Package_Declaration); + + -- Skip 'package'. + Scan; + + Scan_Identifier (Inter); + + -- Skip 'is'. + Expect_Scan (Tok_Is); + + -- Skip 'new'. + Expect_Scan (Tok_New); + + Set_Uninstantiated_Package_Name (Inter, Parse_Name (False)); + + -- Skip 'generic' + Expect_Scan (Tok_Generic); + + -- Skip 'map' + Expect_Scan (Tok_Map); + + -- Skip '(' + Expect_Scan (Tok_Left_Paren); + + case Current_Token is + when Tok_Box => + Map := Null_Iir; + -- Skip '<>' + Scan; + when others => + Map := Parse_Association_List; + end case; + Set_Generic_Map_Aspect_Chain (Inter, Map); + + -- Skip ')' + Expect_Scan (Tok_Right_Paren); + + return Inter; + end Parse_Interface_Package_Declaration; + + -- Precond: identifier or string + -- Postcond: next token + -- + -- [ 2.1 ] + -- designator ::= identifier | operator_symbol + procedure Parse_Subprogram_Designator (Subprg : Iir) is + begin + if Current_Token = Tok_Identifier then + -- Skip identifier. + Scan_Identifier (Subprg); + elsif Current_Token = Tok_String then + if Kind_In (Subprg, Iir_Kind_Procedure_Declaration, + Iir_Kind_Interface_Procedure_Declaration) + then + -- LRM93 2.1 + -- A procedure designator is always an identifier. + Error_Msg_Parse ("a procedure name must be an identifier"); + end if; + -- LRM93 2.1 + -- A function designator is either an identifier or an operator + -- symbol. + Set_Identifier (Subprg, Scan_To_Operator_Name (Get_Token_Location)); + Set_Location (Subprg); + + -- Skip string. + Scan; + else + -- Just to display a parse error. + Expect (Tok_Identifier); + end if; + end Parse_Subprogram_Designator; + + -- Precond: '(' or return or any + -- Postcond: next token + procedure Parse_Subprogram_Parameters_And_Return + (Subprg : Iir; Is_Func : Boolean) + is + Old : Iir; + pragma Unreferenced (Old); + Inters : Iir; + begin + if Current_Token = Tok_Parameter then + Set_Has_Parameter (Subprg, True); + + -- Eat 'parameter' + Scan; + + if Current_Token /= Tok_Left_Paren then + Error_Msg_Parse + ("'parameter' must be followed by a list of parameters"); + end if; + end if; + + if Current_Token = Tok_Left_Paren then + -- Parse the interface declaration. + if Is_Func then + Inters := Parse_Interface_List + (Function_Parameter_Interface_List, Subprg); + else + Inters := Parse_Interface_List + (Procedure_Parameter_Interface_List, Subprg); + end if; + Set_Interface_Declaration_Chain (Subprg, Inters); + end if; + + if Current_Token = Tok_Return then + if not Is_Func then + Error_Msg_Parse + ("'return' not allowed for a procedure", Cont => True); + Error_Msg_Parse + ("(remove return part or declare a function)"); + + -- Skip 'return' + Scan; + + Old := Parse_Type_Mark; + else + -- Skip 'return' + Scan; + + Set_Return_Type_Mark + (Subprg, Parse_Type_Mark (Check_Paren => True)); + end if; + else + if Is_Func then + Error_Msg_Parse ("'return' expected"); + Set_Return_Type_Mark (Subprg, Create_Error_Node); + end if; + end if; + end Parse_Subprogram_Parameters_And_Return; + + -- Precond: PROCEDURE, FUNCTION, PURE, IMPURE + -- Postcond: next token + -- + -- LRM08 6.5.4 Interface subrpogram declarations + -- interface_subprogram_declaration ::= + -- interface_subprogram_specification + -- [ IS interface_subprogram_default ] + -- + -- interface_subrpogram_specification ::= + -- interface_procedure_specification | interface_function_specification + -- + -- interface_procedure_specification ::= + -- PROCEDURE designator + -- [ [ PARAMETER ] ( formal_parameter_list ) ] + -- + -- interface_function_specification ::= + -- [ PURE | IMPURE ] FUNCTION designator + -- [ [ PARAMETER ] ( formal_parameter_list ) ] RETURN type_mark + -- + -- interface_subprogram_default ::= + -- /subprogram/_name | <> + function Parse_Interface_Subprogram_Declaration return Iir + is + Kind : Iir_Kind; + Subprg: Iir; + Old : Iir; + pragma Unreferenced (Old); + begin + -- Create the node. + case Current_Token is + when Tok_Procedure => + Kind := Iir_Kind_Interface_Procedure_Declaration; + when Tok_Function + | Tok_Pure + | Tok_Impure => + Kind := Iir_Kind_Interface_Function_Declaration; + when others => + raise Internal_Error; + end case; + Subprg := Create_Iir (Kind); + Set_Location (Subprg); + + case Current_Token is + when Tok_Procedure => + -- Skip 'procedure'. + Scan; + when Tok_Function => + -- LRM93 2.1 + -- A function is impure if its specification contains the + -- reserved word IMPURE; otherwise it is said to be pure. + Set_Pure_Flag (Subprg, True); + + -- Skip 'function'. + Scan; + when Tok_Pure + | Tok_Impure => + Set_Pure_Flag (Subprg, Current_Token = Tok_Pure); + Set_Has_Pure (Subprg, True); + + -- Eat 'pure' or 'impure'. + Scan; + + Expect_Scan + (Tok_Function, "'function' must follow 'pure' or 'impure'"); + when others => + raise Internal_Error; + end case; + + -- Designator. + Parse_Subprogram_Designator (Subprg); + + Parse_Subprogram_Parameters_And_Return + (Subprg, Kind = Iir_Kind_Interface_Function_Declaration); + + -- TODO: interface_subprogram_default + + return Subprg; + end Parse_Interface_Subprogram_Declaration; + + -- Precond : '(' + -- Postcond: next token + -- + -- LRM08 6.5.6 Interface lists + -- interface_list ::= interface_element { ';' interface_element } + -- + -- interface_element ::= interface_declaration + function Parse_Interface_List (Ctxt : Interface_Kind_Type; Parent : Iir) + return Iir + is + Res, Last : Iir; + Inters : Iir; + Next : Iir; + Prev_Loc : Location_Type; + begin + Prev_Loc := Get_Token_Location; + + -- Skip '('. + Expect_Scan (Tok_Left_Paren); + + Res := Null_Iir; + Last := Null_Iir; + loop + case Current_Token is + when Tok_Identifier + | Tok_Signal + | Tok_Variable + | Tok_Constant + | Tok_File => + -- An inteface object. + Inters := Parse_Interface_Object_Declaration (Ctxt); + when Tok_Package => + if Ctxt /= Generic_Interface_List then + Error_Msg_Parse + ("package interface only allowed in generic interface"); + elsif Flags.Vhdl_Std < Vhdl_08 then + Error_Msg_Parse + ("package interface not allowed before vhdl 08"); + end if; + Inters := Parse_Interface_Package_Declaration; + when Tok_Type => + if Ctxt /= Generic_Interface_List then + Error_Msg_Parse + ("type interface only allowed in generic interface"); + elsif Flags.Vhdl_Std < Vhdl_08 then + Error_Msg_Parse + ("type interface not allowed before vhdl 08"); + end if; + Inters := Create_Iir (Iir_Kind_Interface_Type_Declaration); + + -- Skip 'type'. + Scan; + + Scan_Identifier (Inters); + when Tok_Procedure + | Tok_Pure + | Tok_Impure + | Tok_Function => + if Ctxt /= Generic_Interface_List then + Error_Msg_Parse + ("subprogram interface only allowed in generic interface"); + elsif Flags.Vhdl_Std < Vhdl_08 then + Error_Msg_Parse + ("subprogram interface not allowed before vhdl 08"); + end if; + Inters := Parse_Interface_Subprogram_Declaration; + when Tok_Right_Paren => + if Res = Null_Iir then + Error_Msg_Parse + (Prev_Loc, "empty interface list not allowed"); + else + Error_Msg_Parse + (Prev_Loc, "extra ';' at end of interface list"); + end if; + + -- Skip ')'. + Scan; + + exit; + when others => + Error_Msg_Parse ("interface declaration expected"); + -- Use a variable interface as a fall-back. + Inters := Parse_Interface_Object_Declaration (Ctxt); + end case; + + -- Chain + if Last = Null_Iir then + Res := Inters; + else + Set_Chain (Last, Inters); + end if; + + -- Set parent and set Last to the last interface. + Last := Inters; + loop + Set_Parent (Last, Parent); + Next := Get_Chain (Last); + exit when Next = Null_Iir; + Last := Next; + end loop; + + Prev_Loc := Get_Token_Location; + + case Current_Token is + when Tok_Comma => + Error_Msg_Parse + ("interfaces must be separated by ';' (found ',')"); + + -- Skip ','. + Scan; + when Tok_Semi_Colon => + -- Skip ';'. + Scan; + when Tok_Right_Paren => + -- Skip ')'. + Scan; + + exit; + when others => + -- Try to resync; skip tokens until ';', ')'. Handled nested + -- parenthesis. + Error_Msg_Parse ("';' or ')' expected after interface"); + + if Resync_To_End_Of_Interface then + exit; + end if; + end case; + end loop; + + return Res; + end Parse_Interface_List; + + -- precond : PORT + -- postcond: next token + -- + -- [ LRM93 1.1.1 ] + -- port_clause ::= PORT ( port_list ) ; + -- + -- [ LRM93 1.1.1.2 ] + -- port_list ::= PORT_interface_list + procedure Parse_Port_Clause (Parent : Iir) + is + Res: Iir; + El : Iir; + begin + -- Skip 'port' + pragma Assert (Current_Token = Tok_Port); + Scan; + + Res := Parse_Interface_List (Port_Interface_List, Parent); + + -- Check the interface are signal interfaces. + El := Res; + while El /= Null_Iir loop + if Get_Kind (El) /= Iir_Kind_Interface_Signal_Declaration then + Error_Msg_Parse (+El, "port must be a signal"); + end if; + El := Get_Chain (El); + end loop; + + Scan_Semi_Colon ("port clause"); + Set_Port_Chain (Parent, Res); + end Parse_Port_Clause; + + -- precond : GENERIC + -- postcond: next token + -- + -- [ LRM93 1.1.1, LRM08 6.5.6.2 ] + -- generic_clause ::= GENERIC ( generic_list ) ; + -- + -- [ LRM93 1.1.1.1, LRM08 6.5.6.2] + -- generic_list ::= GENERIC_interface_list + procedure Parse_Generic_Clause (Parent : Iir) + is + Res: Iir; + begin + -- Skip 'generic' + pragma Assert (Current_Token = Tok_Generic); + Scan; + + Res := Parse_Interface_List (Generic_Interface_List, Parent); + Set_Generic_Chain (Parent, Res); + + Scan_Semi_Colon ("generic clause"); + end Parse_Generic_Clause; + + -- precond : a token. + -- postcond: next token + -- + -- [ LRM93 1.1.1 ] + -- entity_header ::= + -- [ FORMAL_generic_clause ] + -- [ FORMAL_port_clause ] + -- + -- [ LRM93 4.5 ] + -- [ LOCAL_generic_clause ] + -- [ LOCAL_port_clause ] + procedure Parse_Generic_Port_Clauses (Parent : Iir) + is + Has_Port, Has_Generic : Boolean; + begin + Has_Port := False; + Has_Generic := False; + loop + if Current_Token = Tok_Generic then + if Has_Generic then + Error_Msg_Parse ("at most one generic clause is allowed"); + end if; + if Has_Port then + Error_Msg_Parse ("generic clause must precede port clause"); + end if; + + if Flag_Elocations then + Set_Generic_Location (Parent, Get_Token_Location); + end if; + + Has_Generic := True; + Parse_Generic_Clause (Parent); + elsif Current_Token = Tok_Port then + if Has_Port then + Error_Msg_Parse ("at most one port clause is allowed"); + end if; + + if Flag_Elocations then + Set_Port_Location (Parent, Get_Token_Location); + end if; + + Has_Port := True; + Parse_Port_Clause (Parent); + else + exit; + end if; + end loop; + end Parse_Generic_Port_Clauses; + + -- precond : a token + -- postcond: next token + -- + -- [ LRM93 3.1.1 ] + -- enumeration_type_definition ::= + -- ( enumeration_literal { , enumeration_literal } ) + -- + -- [ LRM93 3.1.1 ] + -- enumeration_literal ::= identifier | character_literal + function Parse_Enumeration_Type_Definition (Parent : Iir) + return Iir_Enumeration_Type_Definition + is + Pos: Iir_Int32; + Enum_Lit: Iir_Enumeration_Literal; + Enum_Type: Iir_Enumeration_Type_Definition; + Enum_List : Iir_List; + begin + -- This is an enumeration. + Enum_Type := Create_Iir (Iir_Kind_Enumeration_Type_Definition); + Set_Location (Enum_Type); + Enum_List := Create_Iir_List; + + -- LRM93 3.1.1 + -- The position number of the first listed enumeration literal is zero. + Pos := 0; + + -- Eat '('. + Scan; + + if Current_Token = Tok_Right_Paren then + Error_Msg_Parse ("at least one literal must be declared"); + else + loop + if Current_Token = Tok_Identifier + or Current_Token = Tok_Character + then + Enum_Lit := Create_Iir (Iir_Kind_Enumeration_Literal); + Set_Identifier (Enum_Lit, Current_Identifier); + Set_Parent (Enum_Lit, Parent); + Set_Location (Enum_Lit); + Set_Enum_Pos (Enum_Lit, Pos); + + -- LRM93 3.1.1 + -- the position number for each additional enumeration literal + -- is one more than that if its predecessor in the list. + Pos := Pos + 1; + + Append_Element (Enum_List, Enum_Lit); + + -- Skip identifier or character. + Scan; + else + Error_Msg_Parse ("identifier or character expected"); + end if; + + exit when Current_Token /= Tok_Comma; + + -- Skip ','. + Scan; + + if Current_Token = Tok_Right_Paren then + Error_Msg_Parse ("extra ',' ignored"); + exit; + end if; + end loop; + end if; + + -- Skip ')'. + Expect_Scan (Tok_Right_Paren, "')' expected at end of enumeration type"); + + Set_Enumeration_Literal_List (Enum_Type, List_To_Flist (Enum_List)); + + return Enum_Type; + end Parse_Enumeration_Type_Definition; + + -- precond : ARRAY + -- postcond: ?? + -- + -- [ LRM93 3.2.1 ] + -- array_type_definition ::= unconstrained_array_definition + -- | constrained_array_definition + -- + -- unconstrained_array_definition ::= + -- ARRAY ( index_subtype_definition { , index_subtype_definition } ) + -- OF element_subtype_indication + -- + -- constrained_array_definition ::= + -- ARRAY index_constraint OF element_subtype_indication + -- + -- index_subtype_definition ::= type_mark RANGE <> + -- + -- index_constraint ::= ( discrete_range { , discrete_range } ) + -- + -- discrete_range ::= discrete_subtype_indication | range + -- + -- [ LRM08 5.3.2.1 ] + -- array_type_definition ::= unbounded_array_definition + -- | constrained_array_definition + -- + -- unbounded_array_definition ::= + -- ARRAY ( index_subtype_definition { , index_subtype_definition } ) + -- OF element_subtype_indication + function Parse_Array_Type_Definition return Iir + is + Index_Constrained : Boolean; + Array_Constrained : Boolean; + First : Boolean; + Res_Type: Iir; + Index_List : Iir_List; + + Loc : Location_Type; + Def : Iir; + Type_Mark : Iir; + Element_Subtype : Iir; + begin + Loc := Get_Token_Location; + + -- Skip 'array'. + Scan; + + -- Skip '('. + Expect_Scan (Tok_Left_Paren); + + First := True; + Index_List := Create_Iir_List; + + loop + -- The accepted syntax can be one of: + -- * index_subtype_definition, which is: + -- * type_mark RANGE <> + -- * discrete_range, which is either: + -- * /discrete/_subtype_indication + -- * [ resolution_indication ] type_mark [ range_constraint ] + -- * range_constraint ::= RANGE range + -- * range + -- * /range/_attribute_name + -- * simple_expression direction simple_expression + + -- Parse a simple expression (for the range), which can also parse a + -- name. + Type_Mark := Parse_Expression (Prio_Simple); + + case Current_Token is + when Tok_Range => + -- Skip 'range' + Scan; + + if Current_Token = Tok_Box then + -- Parsed 'RANGE <>': this is an index_subtype_definition. + Index_Constrained := False; + Scan; + Def := Type_Mark; + else + -- This is a /discrete/_subtype_indication + Index_Constrained := True; + Def := + Parse_Range_Constraint_Of_Subtype_Indication (Type_Mark); + end if; + when Tok_To + | Tok_Downto => + -- A range + Index_Constrained := True; + Def := Parse_Range_Expression (Type_Mark); + when others => + -- For a /range/_attribute_name + Index_Constrained := True; + Def := Type_Mark; + end case; + + if First then + Array_Constrained := Index_Constrained; + First := False; + else + if Array_Constrained /= Index_Constrained then + Error_Msg_Parse + ("cannot mix constrained and unconstrained index"); + Def := Create_Error_Node (Def); + end if; + end if; + + Append_Element (Index_List, Def); + + exit when Current_Token /= Tok_Comma; + + -- Skip ','. + Scan; + end loop; + + -- Skip ')' and 'of' + Expect_Scan (Tok_Right_Paren); + Expect_Scan (Tok_Of); + + Element_Subtype := Parse_Subtype_Indication; + + if Array_Constrained then + -- Sem_Type will create the array type. + Res_Type := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Set_Array_Element_Constraint (Res_Type, Element_Subtype); + Set_Index_Constraint_List (Res_Type, List_To_Flist (Index_List)); + else + Res_Type := Create_Iir (Iir_Kind_Array_Type_Definition); + Set_Element_Subtype_Indication (Res_Type, Element_Subtype); + Set_Index_Subtype_Definition_List (Res_Type, + List_To_Flist (Index_List)); + end if; + Set_Location (Res_Type, Loc); + + return Res_Type; + end Parse_Array_Type_Definition; + + -- precond : UNITS + -- postcond: next token + -- + -- [ LRM93 3.1.3 ] + -- physical_type_definition ::= + -- range_constraint + -- UNITS + -- base_unit_declaration + -- { secondary_unit_declaration } + -- END UNITS [ PHYSICAL_TYPE_simple_name ] + -- + -- [ LRM93 3.1.3 ] + -- base_unit_declaration ::= identifier ; + -- + -- [ LRM93 3.1.3 ] + -- secondary_unit_declaration ::= identifier = physical_literal ; + function Parse_Physical_Type_Definition (Parent : Iir) + return Iir_Physical_Type_Definition + is + use Iir_Chains.Unit_Chain_Handling; + Res: Iir_Physical_Type_Definition; + Unit: Iir_Unit_Declaration; + Last : Iir_Unit_Declaration; + Multiplier : Iir; + begin + Res := Create_Iir (Iir_Kind_Physical_Type_Definition); + Set_Location (Res); + + -- Skip 'units' + Expect_Scan (Tok_Units); + + -- Parse primary unit. + Unit := Create_Iir (Iir_Kind_Unit_Declaration); + Set_Parent (Unit, Parent); + + Scan_Identifier (Unit); + + Scan_Semi_Colon ("primary physical unit"); + + Build_Init (Last); + Append (Last, Res, Unit); + + -- Parse secondary units. + while Current_Token = Tok_Identifier loop + Unit := Create_Iir (Iir_Kind_Unit_Declaration); + Set_Parent (Unit, Parent); + + Scan_Identifier (Unit); + + -- Skip '='. + Expect_Scan (Tok_Equal); + + case Current_Token is + when Tok_Integer + | Tok_Identifier + | Tok_Real => + Multiplier := Parse_Primary; + when others => + Error_Msg_Parse + ("physical literal expected to define a secondary unit"); + Skip_Until_Semi_Colon; + Multiplier := Null_Iir; + end case; + + if Multiplier /= Null_Iir then + Set_Physical_Literal (Unit, Multiplier); + + case Get_Kind (Multiplier) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Physical_Int_Literal => + null; + when Iir_Kind_Physical_Fp_Literal => + Error_Msg_Parse + ("secondary units may only be defined by an integer"); + when others => + Error_Msg_Parse ("a physical literal is expected here"); + Skip_Until_Semi_Colon; + end case; + end if; + Append (Last, Res, Unit); + Scan_Semi_Colon ("secondary physical unit"); + end loop; + + -- Skip 'end'. + Expect_Scan (Tok_End); + + -- Skip 'units'. + Expect_Scan (Tok_Units); + Set_End_Has_Reserved_Id (Res, True); + + return Res; + end Parse_Physical_Type_Definition; + + -- precond : RECORD + -- postcond: next token + -- + -- [ LRM93 3.2.2 ] + -- record_type_definition ::= + -- RECORD + -- element_declaration + -- { element_declaration } + -- END RECORD [ RECORD_TYPE_simple_name ] + -- + -- element_declaration ::= + -- identifier_list : element_subtype_definition + -- + -- element_subtype_definition ::= subtype_indication + function Parse_Record_Type_Definition return Iir_Record_Type_Definition + is + Res: Iir_Record_Type_Definition; + El_List : Iir_List; + El: Iir_Element_Declaration; + First : Iir; + Pos: Iir_Index32; + Subtype_Indication: Iir; + begin + Res := Create_Iir (Iir_Kind_Record_Type_Definition); + Set_Location (Res); + El_List := Create_Iir_List; + + -- Skip 'record' + Scan; + + Pos := 0; + First := Null_Iir; + loop + pragma Assert (First = Null_Iir); + -- Parse identifier_list + loop + El := Create_Iir (Iir_Kind_Element_Declaration); + Scan_Identifier (El); + + Set_Parent (El, Res); + if First = Null_Iir then + First := El; + end if; + + Append_Element (El_List, El); + Set_Element_Position (El, Pos); + Pos := Pos + 1; + + exit when Current_Token /= Tok_Comma; + + Set_Has_Identifier_List (El, True); + + -- Skip ',' + Scan; + end loop; + + -- Scan ':'. + Expect_Scan (Tok_Colon); + + -- Parse element subtype indication. + Subtype_Indication := Parse_Subtype_Indication; + Set_Subtype_Indication (First, Subtype_Indication); + + First := Null_Iir; + Scan_Semi_Colon_Declaration ("element declaration"); + exit when Current_Token /= Tok_Identifier; + end loop; + + Set_Elements_Declaration_List (Res, List_To_Flist (El_List)); + + if Flag_Elocations then + Create_Elocations (Res); + Set_End_Location (Res, Get_Token_Location); + end if; + + -- Skip 'end' + Expect_Scan (Tok_End); + Expect_Scan (Tok_Record); + Set_End_Has_Reserved_Id (Res, True); + + return Res; + end Parse_Record_Type_Definition; + + -- precond : ACCESS + -- postcond: ? + -- + -- [ LRM93 3.3] + -- access_type_definition ::= ACCESS subtype_indication. + function Parse_Access_Type_Definition return Iir_Access_Type_Definition + is + Res : Iir_Access_Type_Definition; + begin + Res := Create_Iir (Iir_Kind_Access_Type_Definition); + Set_Location (Res); + + -- Skip 'access' + Expect (Tok_Access); + Scan; + + Set_Designated_Subtype_Indication (Res, Parse_Subtype_Indication); + + return Res; + end Parse_Access_Type_Definition; + + -- precond : FILE + -- postcond: next token + -- + -- [ LRM93 3.4 ] + -- file_type_definition ::= FILE OF type_mark + function Parse_File_Type_Definition return Iir_File_Type_Definition + is + Res : Iir_File_Type_Definition; + Type_Mark: Iir; + begin + Res := Create_Iir (Iir_Kind_File_Type_Definition); + Set_Location (Res); + -- Accept token 'file'. + Scan; + Expect_Scan (Tok_Of); + + Type_Mark := Parse_Type_Mark (Check_Paren => True); + if Type_Mark = Null_Iir + or else Get_Kind (Type_Mark) not in Iir_Kinds_Denoting_Name + then + Error_Msg_Parse ("type mark expected"); + else + Set_File_Type_Mark (Res, Type_Mark); + end if; + return Res; + end Parse_File_Type_Definition; + + -- precond : PROTECTED + -- postcond: ';' + -- + -- [ 3.5 ] + -- protected_type_definition ::= protected_type_declaration + -- | protected_type_body + -- + -- [ 3.5.1 ] + -- protected_type_declaration ::= PROTECTED + -- protected_type_declarative_part + -- END PROTECTED [ simple_name ] + -- + -- protected_type_declarative_part ::= + -- { protected_type_declarative_item } + -- + -- protected_type_declarative_item ::= + -- subprogram_declaration + -- | attribute_specification + -- | use_clause + -- + -- [ 3.5.2 ] + -- protected_type_body ::= PROTECTED BODY + -- protected_type_body_declarative_part + -- END PROTECTED BODY [ simple_name ] + -- + -- protected_type_body_declarative_part ::= + -- { protected_type_body_declarative_item } + function Parse_Protected_Type_Definition + (Ident : Name_Id; Loc : Location_Type) return Iir + is + Res : Iir; + Decl : Iir; + begin + -- Skip 'protected'. + Scan; + + if Current_Token = Tok_Body then + Res := Create_Iir (Iir_Kind_Protected_Type_Body); + + -- Skip 'body'. + Scan; + + Decl := Res; + else + Decl := Create_Iir (Iir_Kind_Type_Declaration); + Res := Create_Iir (Iir_Kind_Protected_Type_Declaration); + Set_Location (Res, Loc); + Set_Type_Definition (Decl, Res); + end if; + Set_Identifier (Decl, Ident); + Set_Location (Decl, Loc); + + Parse_Declarative_Part (Res); + + -- Eat 'end'. + Expect_Scan (Tok_End); + + if Flags.Vhdl_Std >= Vhdl_00 then + Expect_Scan (Tok_Protected); + else + -- Avoid weird message: 'protected' expected instead of 'protected'. + Expect_Scan (Tok_Identifier); + end if; + Set_End_Has_Reserved_Id (Res, True); + if Get_Kind (Res) = Iir_Kind_Protected_Type_Body then + Expect_Scan (Tok_Body); + end if; + Check_End_Name (Ident, Res); + return Decl; + end Parse_Protected_Type_Definition; + + -- precond : TYPE + -- postcond: a token + -- + -- [ LRM93 4.1 ] + -- type_definition ::= scalar_type_definition + -- | composite_type_definition + -- | access_type_definition + -- | file_type_definition + -- | protected_type_definition + -- + -- [ LRM93 3.1 ] + -- scalar_type_definition ::= enumeration_type_definition + -- | integer_type_definition + -- | floating_type_definition + -- | physical_type_definition + -- + -- [ LRM93 3.2 ] + -- composite_type_definition ::= array_type_definition + -- | record_type_definition + -- + -- [ LRM93 3.1.2 ] + -- integer_type_definition ::= range_constraint + -- + -- [ LRM93 3.1.4 ] + -- floating_type_definition ::= range_constraint + function Parse_Type_Declaration (Parent : Iir) return Iir + is + Def : Iir; + Loc : Location_Type; + Ident : Name_Id; + Decl : Iir; + Start_Loc : Location_Type; + begin + -- The current token must be type. + pragma Assert (Current_Token = Tok_Type); + Start_Loc := Get_Token_Location; + + -- Skip 'type'. + Scan; + + -- Get the identifier + Loc := Get_Token_Location; + if Current_Token = Tok_Identifier then + Ident := Current_Identifier; + + -- Skip identifier. + Scan; + else + Expect (Tok_Identifier, "identifier is expected after 'type'"); + Ident := Null_Identifier; + end if; + + + if Current_Token = Tok_Semi_Colon then + -- If there is a ';', this is an incomplete type declaration. + Scan; + + Decl := Create_Iir (Iir_Kind_Type_Declaration); + Set_Identifier (Decl, Ident); + Set_Location (Decl, Loc); + + if Flag_Elocations then + Create_Elocations (Decl); + Set_Start_Location (Decl, Start_Loc); + end if; + + return Decl; + end if; + + Expect_Scan (Tok_Is, "'is' expected here"); + + case Current_Token is + when Tok_Left_Paren => + -- This is an enumeration. + Def := Parse_Enumeration_Type_Definition (Parent); + Decl := Null_Iir; + + when Tok_Range => + -- This is a range definition. + Decl := Create_Iir (Iir_Kind_Anonymous_Type_Declaration); + Set_Identifier (Decl, Ident); + Set_Location (Decl, Loc); + + -- Skip 'range' + Scan; + + Def := Parse_Range_Constraint; + Set_Type_Definition (Decl, Def); + + if Current_Token = Tok_Units then + -- A physical type definition. + declare + Phys_Def : Iir; + begin + Phys_Def := Parse_Physical_Type_Definition (Parent); + if Current_Token = Tok_Identifier then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("simple_name not allowed here in vhdl87"); + end if; + Check_End_Name (Get_Identifier (Decl), Phys_Def); + end if; + Set_Range_Constraint (Phys_Def, Def); + Set_Type_Definition (Decl, Phys_Def); + end; + end if; + + when Tok_Array => + Def := Parse_Array_Type_Definition; + Decl := Null_Iir; + + when Tok_Record => + Decl := Create_Iir (Iir_Kind_Type_Declaration); + Set_Identifier (Decl, Ident); + Set_Location (Decl, Loc); + Def := Parse_Record_Type_Definition; + Set_Type_Definition (Decl, Def); + if Current_Token = Tok_Identifier then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("simple_name not allowed here in vhdl87"); + end if; + Check_End_Name (Get_Identifier (Decl), Def); + end if; + + when Tok_Access => + Def := Parse_Access_Type_Definition; + Decl := Null_Iir; + + when Tok_File => + Def := Parse_File_Type_Definition; + Decl := Null_Iir; + + when Tok_Identifier => + if Current_Identifier = Name_Protected then + Error_Msg_Parse ("protected type not allowed in vhdl87/93"); + Decl := Parse_Protected_Type_Definition (Ident, Loc); + else + Error_Msg_Parse ("type %i cannot be defined from another type", + (1 => +Ident), Cont => True); + Error_Msg_Parse ("(you should declare a subtype)"); + Decl := Create_Iir (Iir_Kind_Type_Declaration); + end if; + + when Tok_Protected => + if Flags.Vhdl_Std < Vhdl_00 then + Error_Msg_Parse ("protected type not allowed in vhdl87/93"); + end if; + Decl := Parse_Protected_Type_Definition (Ident, Loc); + + when others => + Error_Msg_Parse ("missing type definition after 'is'"); + Decl := Create_Iir (Iir_Kind_Type_Declaration); + end case; + + if Decl = Null_Iir then + case Get_Kind (Def) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Access_Type_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_File_Type_Definition => + Decl := Create_Iir (Iir_Kind_Type_Declaration); + when Iir_Kind_Array_Subtype_Definition => + Decl := Create_Iir (Iir_Kind_Anonymous_Type_Declaration); + when others => + Error_Kind ("parse_type_declaration", Def); + end case; + Set_Type_Definition (Decl, Def); + end if; + Set_Identifier (Decl, Ident); + Set_Location (Decl, Loc); + + -- ';' is expected after end of type declaration + Scan_Semi_Colon_Declaration ("type declaration"); + + if Flag_Elocations then + Create_Elocations (Decl); + Set_Start_Location (Decl, Start_Loc); + end if; + + return Decl; + end Parse_Type_Declaration; + + -- precond: '(' or identifier + -- postcond: next token + -- + -- [ LRM08 6.3 ] + -- + -- resolution_indication ::= + -- resolution_function_name | ( element_resolution ) + -- + -- element_resolution ::= + -- array_element_resolution | record_resolution + -- + -- array_element_resolution ::= resolution_indication + -- + -- record_resolution ::= + -- record_element_resolution { , record_element_resolution } + -- + -- record_element_resolution ::= + -- record_element_simple_name resolution_indication + function Parse_Resolution_Indication return Iir + is + Ind : Iir; + Def : Iir; + Loc : Location_Type; + begin + if Current_Token = Tok_Identifier then + -- Resolution function name. + return Parse_Name (Allow_Indexes => False); + elsif Current_Token = Tok_Left_Paren then + -- Element resolution. + Loc := Get_Token_Location; + + -- Eat '(' + Scan; + + Ind := Parse_Resolution_Indication; + if Current_Token = Tok_Identifier + or else Current_Token = Tok_Left_Paren + then + declare + Id : Name_Id; + El : Iir; + First, Last : Iir; + begin + -- This was in fact a record_resolution. + if Get_Kind (Ind) = Iir_Kind_Simple_Name then + Id := Get_Identifier (Ind); + else + Error_Msg_Parse (+Ind, "element name expected"); + Id := Null_Identifier; + end if; + Free_Iir (Ind); + + Def := Create_Iir (Iir_Kind_Record_Resolution); + Set_Location (Def, Loc); + Sub_Chain_Init (First, Last); + loop + El := Create_Iir (Iir_Kind_Record_Element_Resolution); + Set_Location (El, Loc); + Set_Identifier (El, Id); + Set_Resolution_Indication (El, Parse_Resolution_Indication); + Sub_Chain_Append (First, Last, El); + exit when Current_Token /= Tok_Comma; + + -- Eat ',' + Scan; + + if Current_Token /= Tok_Identifier then + Error_Msg_Parse ("record element identifier expected"); + exit; + end if; + Id := Current_Identifier; + Loc := Get_Token_Location; + + -- Eat identifier + Scan; + end loop; + Set_Record_Element_Resolution_Chain (Def, First); + end; + else + Def := Create_Iir (Iir_Kind_Array_Element_Resolution); + Set_Location (Def, Loc); + Set_Resolution_Indication (Def, Ind); + end if; + + -- Eat ')' + Expect_Scan (Tok_Right_Paren); + + return Def; + else + Error_Msg_Parse ("resolution indication expected"); + return Null_Iir; + end if; + end Parse_Resolution_Indication; + + -- precond : '(' + -- postcond: next token + -- + -- [ LRM08 6.3 Subtype declarations ] + -- element_constraint ::= + -- array_constraint | record_constraint + -- + -- [ LRM08 5.3.2.1 Array types ] + -- array_constraint ::= + -- index_constraint [ array_element_constraint ] + -- | ( open ) [ array_element_constraint ] + -- + -- array_element_constraint ::= element_constraint + -- + -- RES is the resolution_indication of the subtype indication. + function Parse_Element_Constraint return Iir + is + Def : Iir; + El : Iir; + Index_List : Iir_List; + begin + -- Index_constraint. + Def := Create_Iir (Iir_Kind_Array_Subtype_Definition); + Set_Location (Def); + + -- Eat '('. + Scan; + + if Current_Token = Tok_Open then + -- Eat 'open'. + Scan; + else + Index_List := Create_Iir_List; + -- index_constraint ::= (discrete_range {, discrete_range} ) + loop + El := Parse_Discrete_Range; + Append_Element (Index_List, El); + + exit when Current_Token /= Tok_Comma; + + -- Eat ',' + Scan; + end loop; + Set_Index_Constraint_List (Def, List_To_Flist (Index_List)); + end if; + + -- Eat ')' + Expect_Scan (Tok_Right_Paren); + + if Current_Token = Tok_Left_Paren then + Set_Array_Element_Constraint (Def, Parse_Element_Constraint); + end if; + return Def; + end Parse_Element_Constraint; + + -- precond : tolerance + -- postcond: next token + -- + -- [ LRM93 4.2 ] + -- tolerance_aspect ::= TOLERANCE string_expression + function Parse_Tolerance_Aspect_Opt return Iir is + begin + if AMS_Vhdl + and then Current_Token = Tok_Tolerance + then + Scan; + return Parse_Expression; + else + return Null_Iir; + end if; + end Parse_Tolerance_Aspect_Opt; + + -- precond : identifier or '(' + -- postcond: next token + -- + -- [ LRM93 4.2 ] + -- subtype_indication ::= + -- [ RESOLUTION_FUNCTION_name ] type_mark [ constraint ] + -- + -- constraint ::= range_constraint | index_constraint + -- + -- [ LRM08 6.3 ] + -- subtype_indication ::= + -- [ resolution_indication ] type_mark [ constraint ] + -- + -- constraint ::= + -- range_constraint | array_constraint | record_constraint + -- + -- NAME is the type_mark when already parsed (in range expression or + -- allocator by type). + function Parse_Subtype_Indication (Name : Iir := Null_Iir) return Iir + is + Type_Mark : Iir; + Def: Iir; + Resolution_Indication: Iir; + Tolerance : Iir; + begin + -- FIXME: location. + Resolution_Indication := Null_Iir; + Def := Null_Iir; + + if Name /= Null_Iir then + -- The type_mark was already parsed. + Type_Mark := Name; + Check_Type_Mark (Name); + else + if Current_Token = Tok_Left_Paren then + if Vhdl_Std < Vhdl_08 then + Error_Msg_Parse + ("resolution_indication not allowed before vhdl08"); + end if; + Resolution_Indication := Parse_Resolution_Indication; + end if; + if Current_Token /= Tok_Identifier then + Error_Msg_Parse ("type mark expected in a subtype indication"); + return Create_Error_Node; + end if; + Type_Mark := Parse_Type_Mark (Check_Paren => False); + end if; + + if Current_Token = Tok_Identifier then + if Resolution_Indication /= Null_Iir then + Error_Msg_Parse ("resolution function already indicated"); + end if; + Resolution_Indication := Type_Mark; + Type_Mark := Parse_Type_Mark (Check_Paren => False); + end if; + + case Current_Token is + when Tok_Left_Paren => + -- element_constraint. + Def := Parse_Element_Constraint; + Set_Subtype_Type_Mark (Def, Type_Mark); + Set_Resolution_Indication (Def, Resolution_Indication); + Set_Tolerance (Def, Parse_Tolerance_Aspect_Opt); + + when Tok_Range => + -- range_constraint. + -- Skip 'range' + Scan; + + Def := Parse_Range_Constraint_Of_Subtype_Indication + (Type_Mark, Resolution_Indication); + + when others => + Tolerance := Parse_Tolerance_Aspect_Opt; + if Resolution_Indication /= Null_Iir + or else Tolerance /= Null_Iir + then + -- A subtype needs to be created. + Def := Create_Iir (Iir_Kind_Subtype_Definition); + if Type_Mark /= Null_Iir then + Location_Copy (Def, Type_Mark); + Set_Subtype_Type_Mark (Def, Type_Mark); + end if; + Set_Resolution_Indication (Def, Resolution_Indication); + Set_Tolerance (Def, Tolerance); + else + -- This is just an alias. + Def := Type_Mark; + end if; + end case; + return Def; + end Parse_Subtype_Indication; + + -- precond : SUBTYPE + -- postcond: next token + -- + -- [ LRM93 4.2 ] + -- subtype_declaration ::= SUBTYPE identifier IS subtype_indication ; + function Parse_Subtype_Declaration (Parent : Iir) + return Iir_Subtype_Declaration + is + Decl: Iir_Subtype_Declaration; + Def: Iir; + Start_Loc : Location_Type; + begin + Decl := Create_Iir (Iir_Kind_Subtype_Declaration); + Set_Parent (Decl, Parent); + Start_Loc := Get_Token_Location; + + -- Eat 'subtype'. + Scan; + + Scan_Identifier (Decl); + + -- Skip 'is'. + Expect_Scan (Tok_Is); + + Def := Parse_Subtype_Indication; + Set_Subtype_Indication (Decl, Def); + + -- Skip ';'. + Scan_Semi_Colon_Declaration ("subtype decalaration"); + + if Flag_Elocations then + Create_Elocations (Decl); + Set_Start_Location (Decl, Start_Loc); + end if; + + return Decl; + end Parse_Subtype_Declaration; + + -- precond : NATURE + -- postcond: a token + -- + -- [ LRM93 4.8 ] + -- nature_definition ::= scalar_nature_definition + -- | composite_nature_definition + -- + -- [ LRM93 3.5.1 ] + -- scalar_nature_definition ::= type_mark ACROSS + -- type_mark THROUGH + -- identifier REFERENCE + -- + -- [ LRM93 3.5.2 ] + -- composite_nature_definition ::= array_nature_definition + -- | record_nature_definition + function Parse_Nature_Declaration return Iir + is + Def : Iir; + Ref : Iir; + Loc : Location_Type; + Ident : Name_Id; + Decl : Iir; + begin + -- Skip 'nature'. + pragma Assert (Current_Token = Tok_Nature); + Scan; + + -- Get the identifier + Expect (Tok_Identifier, + "an identifier is expected after 'nature'"); + Loc := Get_Token_Location; + Ident := Current_Identifier; + + Scan; + + -- Skip 'is'. + Expect_Scan (Tok_Is); + + case Current_Token is + when Tok_Array => + -- TODO + Error_Msg_Parse ("array nature definition not supported"); + Def := Null_Iir; + Skip_Until_Semi_Colon; + when Tok_Record => + -- TODO + Error_Msg_Parse ("record nature definition not supported"); + Def := Null_Iir; + Skip_Until_Semi_Colon; + when Tok_Identifier => + Def := Create_Iir (Iir_Kind_Scalar_Nature_Definition); + Set_Location (Def, Loc); + Set_Across_Type (Def, Parse_Type_Mark); + if Current_Token = Tok_Across then + Scan; + else + Expect (Tok_Across, "'across' expected after type mark"); + end if; + Set_Through_Type (Def, Parse_Type_Mark); + if Current_Token = Tok_Through then + Scan; + else + Expect (Tok_Across, "'through' expected after type mark"); + end if; + if Current_Token = Tok_Identifier then + Ref := Create_Iir (Iir_Kind_Terminal_Declaration); + Scan_Identifier (Ref); + Set_Reference (Def, Ref); + if Current_Token = Tok_Reference then + Scan; + else + Expect (Tok_Reference, "'reference' expected"); + Skip_Until_Semi_Colon; + end if; + else + Error_Msg_Parse ("reference identifier expected"); + Skip_Until_Semi_Colon; + end if; + when others => + Error_Msg_Parse ("nature definition expected here"); + Skip_Until_Semi_Colon; + end case; + + Decl := Create_Iir (Iir_Kind_Nature_Declaration); + Set_Nature (Decl, Def); + Set_Identifier (Decl, Ident); + Set_Location (Decl, Loc); + + -- ';' is expected after end of type declaration + Scan_Semi_Colon_Declaration ("nature declaration"); + + return Decl; + end Parse_Nature_Declaration; + + -- precond : identifier + -- postcond: next token + -- + -- LRM 4.8 Nature declaration + -- + -- subnature_indication ::= + -- nature_mark [ index_constraint ] + -- [ TOLERANCE string_expression ACROSS string_expression THROUGH ] + -- + -- nature_mark ::= + -- nature_name | subnature_name + function Parse_Subnature_Indication return Iir + is + Nature_Mark : Iir; + begin + if Current_Token /= Tok_Identifier then + Error_Msg_Parse ("nature mark expected in a subnature indication"); + return Null_Iir; + end if; + Nature_Mark := Parse_Name (Allow_Indexes => False); + + if Current_Token = Tok_Left_Paren then + -- TODO + Error_Msg_Parse + ("index constraint not supported for subnature indication"); + raise Internal_Error; + end if; + + if Current_Token = Tok_Tolerance then + Error_Msg_Parse ("tolerance not supported for subnature indication"); + raise Internal_Error; + end if; + return Nature_Mark; + end Parse_Subnature_Indication; + + -- precond : TERMINAL + -- postcond: next token. + -- + -- [ 4.3.1.5 Terminal declarations ] + -- terminal_declaration ::= + -- TERMINAL identifier_list : subnature_indication + function Parse_Terminal_Declaration (Parent : Iir) return Iir + is + -- First and last element of the chain to be returned. + First, Last : Iir; + Terminal : Iir; + Subnature : Iir; + begin + Sub_Chain_Init (First, Last); + + -- Skip 'terminal'. + Scan; + + loop + -- 'terminal' or "," was just scanned. + Terminal := Create_Iir (Iir_Kind_Terminal_Declaration); + + Scan_Identifier (Terminal); + + Set_Parent (Terminal, Parent); + + Sub_Chain_Append (First, Last, Terminal); + + exit when Current_Token /= Tok_Comma; + -- Skip ','. + Scan; + end loop; + + -- Skip ':'. + Expect_Scan (Tok_Colon); + + Subnature := Parse_Subnature_Indication; + + Terminal := First; + while Terminal /= Null_Iir loop + -- Type definitions are factorized. This is OK, but not done by + -- sem. + if Terminal = First then + Set_Nature (Terminal, Subnature); + else + Set_Nature (Terminal, Null_Iir); + end if; + Terminal := Get_Chain (Terminal); + end loop; + + -- Skip ';'. + Scan_Semi_Colon_Declaration ("terminal declaration"); + + return First; + end Parse_Terminal_Declaration; + + -- precond : QUANTITY + -- postcond: next token. + -- + -- [ 4.3.1.6 Quantity declarations ] + -- quantity_declaration ::= + -- free_quantity_declaration + -- | branch_quantity_declaration + -- | source_quantity_declaration + -- + -- free_quantity_declaration ::= + -- QUANTITY identifier_list : subtype_indication [ := expression ] ; + -- + -- branch_quantity_declaration ::= + -- QUANTITY [ across_aspect ] [ through_aspect ] terminal_aspect ; + -- + -- source_quantity_declaration ::= + -- QUANTITY identifier_list : subtype_indication source_aspect ; + -- + -- across_aspect ::= + -- identifier_list [ tolerance_aspect ] [ := expression ] ACROSS + -- + -- through_aspect ::= + -- identifier_list [ tolerance_aspect ] [ := expression ] THROUGH + -- + -- terminal_aspect ::= + -- plus_terminal_name [ TO minus_terminal_name ] + function Parse_Quantity_Declaration (Parent : Iir) return Iir + is + -- First and last element of the chain to be returned. + First, Last : Iir; + Object : Iir; + New_Object : Iir; + Tolerance : Iir; + Default_Value : Iir; + Kind : Iir_Kind; + Plus_Terminal : Iir; + begin + Sub_Chain_Init (First, Last); + + -- Eat 'quantity' + Scan; + + loop + -- Quantity or "," was just scanned. We assume a free quantity + -- declaration and will change to branch or source quantity if + -- necessary. + Object := Create_Iir (Iir_Kind_Free_Quantity_Declaration); + + Scan_Identifier (Object); + + Set_Parent (Object, Parent); + + Sub_Chain_Append (First, Last, Object); + + exit when Current_Token /= Tok_Comma; + + -- Eat ',' + Scan; + end loop; + + case Current_Token is + when Tok_Colon => + -- Either a free quantity (or a source quantity) + -- TODO + raise Program_Error; + when Tok_Tolerance + | Tok_Assign + | Tok_Across + | Tok_Through => + -- A branch quantity + + -- Parse tolerance aspect + Tolerance := Parse_Tolerance_Aspect_Opt; + + -- Parse default value + if Current_Token = Tok_Assign then + Scan; + Default_Value := Parse_Expression; + else + Default_Value := Null_Iir; + end if; + + case Current_Token is + when Tok_Across => + Kind := Iir_Kind_Across_Quantity_Declaration; + when Tok_Through => + Kind := Iir_Kind_Through_Quantity_Declaration; + when others => + Error_Msg_Parse ("'across' or 'through' expected here"); + Skip_Until_Semi_Colon; + return Null_Iir; + end case; + + -- Eat across/through + Scan; + + -- Change declarations + Object := First; + Sub_Chain_Init (First, Last); + while Object /= Null_Iir loop + New_Object := Create_Iir (Kind); + Location_Copy (New_Object, Object); + Set_Identifier (New_Object, Get_Identifier (Object)); + Set_Parent (New_Object, Parent); + Set_Tolerance (New_Object, Tolerance); + Set_Default_Value (New_Object, Default_Value); + + Sub_Chain_Append (First, Last, New_Object); + + if Object /= First then + Set_Plus_Terminal (New_Object, Null_Iir); + end if; + New_Object := Get_Chain (Object); + Free_Iir (Object); + Object := New_Object; + end loop; + + -- Parse terminal (or first identifier of through declarations) + Plus_Terminal := Parse_Name; + + case Current_Token is + when Tok_Comma + | Tok_Tolerance + | Tok_Assign + | Tok_Through + | Tok_Across => + -- Through quantity declaration. Convert the Plus_Terminal + -- to a declaration. + Object := Create_Iir (Iir_Kind_Through_Quantity_Declaration); + New_Object := Object; + Location_Copy (Object, Plus_Terminal); + if Get_Kind (Plus_Terminal) /= Iir_Kind_Simple_Name then + Error_Msg_Parse + ("identifier for quantity declaration expected"); + else + Set_Identifier (Object, Get_Identifier (Plus_Terminal)); + end if; + Set_Plus_Terminal (Object, Null_Iir); + Free_Iir (Plus_Terminal); + + loop + Set_Parent (Object, Parent); + Sub_Chain_Append (First, Last, Object); + exit when Current_Token /= Tok_Comma; + -- Skip ','. + Scan; + + Object := Create_Iir + (Iir_Kind_Through_Quantity_Declaration); + Scan_Identifier (Object); + Set_Plus_Terminal (Object, Null_Iir); + + end loop; + + -- Parse tolerance aspect + Set_Tolerance (Object, Parse_Tolerance_Aspect_Opt); + + -- Parse default value + if Current_Token = Tok_Assign then + Scan; + Set_Default_Value (Object, Parse_Expression); + end if; + + -- Scan 'through' + if Current_Token = Tok_Through then + Scan; + elsif Current_Token = Tok_Across then + Error_Msg_Parse ("across quantity declaration must appear" + & " before though declaration"); + Scan; + else + Error_Msg_Parse ("'through' expected"); + end if; + + -- Parse plus terminal + Plus_Terminal := Parse_Name; + when others => + null; + end case; + + Set_Plus_Terminal (First, Plus_Terminal); + + -- Parse minus terminal (if present) + if Current_Token = Tok_To then + Scan; + Set_Minus_Terminal (First, Parse_Name); + end if; + when others => + Error_Msg_Parse ("missing type or across/throught aspect " + & "in quantity declaration"); + Skip_Until_Semi_Colon; + return Null_Iir; + end case; + + -- Skip ';'. + Scan_Semi_Colon_Declaration ("quantity declaration"); + + return First; + end Parse_Quantity_Declaration; + + -- precond : token (CONSTANT, SIGNAL, VARIABLE, FILE) + -- postcond: next token. + -- + -- KIND can be iir_kind_constant_declaration, iir_kind_file_declaration + -- or iir_kind_variable_declaration + -- + -- [ LRM93 4.3.1 ] + -- object_declaration ::= constant_declaration + -- | signal_declaration + -- | variable_declaration + -- | file_declaration + -- + -- [ LRM93 4.3.1.1 ] + -- constant_declaration ::= + -- CONSTANT identifier_list : subtype_indication [ := expression ] + -- + -- [ LRM87 4.3.2 ] + -- file_declaration ::= + -- FILE identifier : subtype_indication IS [ mode ] file_logical_name + -- + -- [ LRM93 4.3.1.4 ] + -- file_declaration ::= + -- FILE identifier_list : subtype_indication [ file_open_information ] + -- + -- [ LRM93 4.3.1.4 ] + -- file_open_information ::= + -- [ OPEN FILE_OPEN_KIND_expression ] IS file_logical_name + -- + -- [ LRM93 4.3.1.4 ] + -- file_logical_name ::= STRING_expression + -- + -- [ LRM93 4.3.1.3 ] + -- variable_declaration ::= + -- [ SHARED ] VARIABLE identifier_list : subtype_indication + -- [ := expression ] + -- + -- [ LRM93 4.3.1.2 ] + -- signal_declaration ::= + -- SIGNAL identifier_list : subtype_information [ signal_kind ] + -- [ := expression ] + -- + -- [ LRM93 4.3.1.2 ] + -- signal_kind ::= REGISTER | BUS + -- + -- FIXME: file_open_information. + function Parse_Object_Declaration (Parent : Iir) return Iir + is + -- First and last element of the chain to be returned. + First, Last : Iir; + Object: Iir; + Object_Type: Iir; + Default_Value : Iir; + Mode: Iir_Mode; + Signal_Kind : Iir_Signal_Kind; + Is_Guarded : Boolean; + Open_Kind : Iir; + Logical_Name : Iir; + Kind: Iir_Kind; + Shared : Boolean; + Has_Mode : Boolean; + Start_Loc : Location_Type; + begin + Sub_Chain_Init (First, Last); + + -- Object keyword was just scanned. + Start_Loc := Get_Token_Location; + case Current_Token is + when Tok_Signal => + Kind := Iir_Kind_Signal_Declaration; + + -- Skip 'signal'. + Scan; + + when Tok_Constant => + Kind := Iir_Kind_Constant_Declaration; + + -- Skip 'constant'. + Scan; + + when Tok_File => + Kind := Iir_Kind_File_Declaration; + + -- Skip 'file'. + Scan; + + when Tok_Variable => + Kind := Iir_Kind_Variable_Declaration; + Shared := False; + + -- Skip 'variable'. + Scan; + + when Tok_Shared => + Kind := Iir_Kind_Variable_Declaration; + Shared := True; + + -- Skip 'shared'. + Scan; + + Expect_Scan (Tok_Variable); + when others => + raise Internal_Error; + end case; + + loop + -- Object or "," was just scanned. + Object := Create_Iir (Kind); + if Kind = Iir_Kind_Variable_Declaration then + Set_Shared_Flag (Object, Shared); + end if; + + Scan_Identifier (Object); + + Set_Parent (Object, Parent); + + if Flag_Elocations then + Create_Elocations (Object); + Set_Start_Location (Object, Start_Loc); + end if; + + Sub_Chain_Append (First, Last, Object); + + exit when Current_Token /= Tok_Comma; + + -- Skip ','. + Scan; + Set_Has_Identifier_List (Object, True); + end loop; + + -- Skip ':'. + Expect_Scan (Tok_Colon); + + Object_Type := Parse_Subtype_Indication; + + if Kind = Iir_Kind_Signal_Declaration then + Parse_Signal_Kind (Is_Guarded, Signal_Kind); + end if; + + if Current_Token = Tok_Assign then + if Kind = Iir_Kind_File_Declaration then + Error_Msg_Parse + ("default expression not allowed for a file declaration"); + end if; + + -- Skip ':='. + Scan; + + Default_Value := Parse_Expression; + elsif Current_Token = Tok_Equal then + Error_Msg_Parse ("= should be := for initial value"); + + -- Skip '=' + Scan; + + Default_Value := Parse_Expression; + else + Default_Value := Null_Iir; + end if; + + if Kind = Iir_Kind_File_Declaration then + if Current_Token = Tok_Open then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("'open' and open kind expression not allowed in vhdl 87"); + end if; + Scan; + Open_Kind := Parse_Expression; + else + Open_Kind := Null_Iir; + end if; + + -- LRM 4.3.1.4 + -- The default mode is IN, if no mode is specified. + Mode := Iir_In_Mode; + + Logical_Name := Null_Iir; + Has_Mode := False; + if Current_Token = Tok_Is then + -- Skip 'is'. + Scan; + + case Current_Token is + when Tok_In | Tok_Out | Tok_Inout => + if Flags.Vhdl_Std >= Vhdl_93 then + Error_Msg_Parse ("mode allowed only in vhdl 87"); + end if; + Mode := Parse_Mode; + if Mode = Iir_Inout_Mode then + Error_Msg_Parse ("inout mode not allowed for file"); + end if; + Has_Mode := True; + when others => + null; + end case; + Logical_Name := Parse_Expression; + elsif Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("file name expected (vhdl 87)"); + end if; + end if; + + Set_Subtype_Indication (First, Object_Type); + if Kind /= Iir_Kind_File_Declaration then + Set_Default_Value (First, Default_Value); + end if; + + Object := First; + while Object /= Null_Iir loop + case Kind is + when Iir_Kind_File_Declaration => + Set_Mode (Object, Mode); + Set_File_Open_Kind (Object, Open_Kind); + Set_File_Logical_Name (Object, Logical_Name); + Set_Has_Mode (Object, Has_Mode); + when Iir_Kind_Signal_Declaration => + Set_Guarded_Signal_Flag (Object, Is_Guarded); + Set_Signal_Kind (Object, Signal_Kind); + when others => + null; + end case; + Object := Get_Chain (Object); + end loop; + + -- Skip ';'. + Scan_Semi_Colon_Declaration ("object declaration"); + + return First; + end Parse_Object_Declaration; + + -- precond : COMPONENT + -- postcond: next token. + -- + -- [ LRM93 4.5 ] + -- component_declaration ::= + -- COMPONENT identifier [ IS ] + -- [ LOCAL_generic_clause ] + -- [ LOCAL_port_clause ] + -- END COMPONENT [ COMPONENT_simple_name ] ; + function Parse_Component_Declaration return Iir_Component_Declaration + is + Component : Iir_Component_Declaration; + begin + Component := Create_Iir (Iir_Kind_Component_Declaration); + if Flag_Elocations then + Create_Elocations (Component); + Set_Start_Location (Component, Get_Token_Location); + end if; + + -- Eat 'component'. + pragma Assert (Current_Token = Tok_Component); + Scan; + + Scan_Identifier (Component); + + if Current_Token = Tok_Is then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("""is"" keyword is not allowed here by vhdl 87"); + end if; + Set_Has_Is (Component, True); + + -- Eat 'is'. + Scan; + end if; + Parse_Generic_Port_Clauses (Component); + + if Flag_Elocations then + Set_End_Location (Component, Get_Token_Location); + end if; + + Check_End_Name (Tok_Component, Component); + + -- Skip ';'. + Expect_Scan (Tok_Semi_Colon); + + return Component; + end Parse_Component_Declaration; + + -- precond : '[' + -- postcond: next token after ']' + -- + -- [ LRM93 2.3.2 ] + -- signature ::= [ [ type_mark { , type_mark } ] [ RETURN type_mark ] ] + function Parse_Signature return Iir_Signature + is + Res : Iir_Signature; + List : Iir_List; + begin + Expect (Tok_Left_Bracket); + Res := Create_Iir (Iir_Kind_Signature); + Set_Location (Res); + + -- Skip '[' + Scan; + + -- List of type_marks. + if Current_Token = Tok_Identifier then + List := Create_Iir_List; + loop + Append_Element (List, Parse_Type_Mark (Check_Paren => True)); + exit when Current_Token /= Tok_Comma; + + -- Skip ','. + Scan; + end loop; + Set_Type_Marks_List (Res, List_To_Flist (List)); + end if; + + if Current_Token = Tok_Return then + -- Skip 'return' + Scan; + + Set_Return_Type_Mark (Res, Parse_Name); + end if; + + -- Skip ']' + Expect (Tok_Right_Bracket); + Scan; + + return Res; + end Parse_Signature; + + -- precond : ALIAS + -- postcond: next token + -- + -- [ LRM93 4.3.3 ] + -- alias_declaration ::= + -- ALIAS alias_designator [ : subtype_indication ] + -- IS name [ signature ] ; + -- + -- [ LRM93 4.3.3 ] + -- alias_designator ::= identifier | character_literal | operator_symbol + -- + -- FIXME: signature is not part of the node. + function Parse_Alias_Declaration return Iir + is + Res: Iir; + Ident : Name_Id; + Start_Loc : Location_Type; + begin + Start_Loc := Get_Token_Location; + + -- Skip 'alias'. + pragma Assert (Current_Token = Tok_Alias); + Scan; + + Res := Create_Iir (Iir_Kind_Object_Alias_Declaration); + Set_Location (Res); + + case Current_Token is + when Tok_Identifier + | Tok_Character => + Ident := Current_Identifier; + + -- Skip identifier/character. + Scan; + when Tok_String => + Ident := Scan_To_Operator_Name (Get_Token_Location); + + -- Skip operator. + Scan; + -- FIXME: vhdl87 + -- FIXME: operator symbol. + when others => + Error_Msg_Parse ("alias designator expected"); + Ident := Null_Identifier; + end case; + Set_Identifier (Res, Ident); + + if Current_Token = Tok_Colon then + -- Skip ':'. + Scan; + Set_Subtype_Indication (Res, Parse_Subtype_Indication); + end if; + + -- FIXME: nice message if token is ':=' ? + Expect_Scan (Tok_Is); + Set_Name (Res, Parse_Signature_Name); + + if Flag_Elocations then + Create_Elocations (Res); + Set_Start_Location (Res, Start_Loc); + end if; + + -- Skip ';'. + Scan_Semi_Colon_Declaration ("alias declaration"); + + return Res; + end Parse_Alias_Declaration; + + -- precond : FOR + -- postcond: next token. + -- + -- [ LRM93 5.2 ] + -- configuration_specification ::= + -- FOR component_specification binding_indication ; + function Parse_Configuration_Specification + return Iir_Configuration_Specification + is + Res : Iir_Configuration_Specification; + begin + Res := Create_Iir (Iir_Kind_Configuration_Specification); + Set_Location (Res); + + -- Eat 'for'. + Expect_Scan (Tok_For); + + Parse_Component_Specification (Res); + Set_Binding_Indication (Res, Parse_Binding_Indication); + + -- Skip ';'. + Scan_Semi_Colon_Declaration ("configuration specification"); + + return Res; + end Parse_Configuration_Specification; + + -- precond : next token + -- postcond: next token + -- + -- [ LRM93 5.2 ] + -- entity_class := ENTITY | ARCHITECTURE | CONFIGURATION | PROCEDURE + -- | FUNCTION | PACKAGE | TYPE | SUBTYPE | CONSTANT + -- | SIGNAL | VARIABLE | COMPONENT | LABEL | LITERAL + -- | UNITS | GROUP | FILE + function Parse_Entity_Class return Token_Type + is + Res : Token_Type; + begin + case Current_Token is + when Tok_Entity + | Tok_Architecture + | Tok_Configuration + | Tok_Procedure + | Tok_Function + | Tok_Package + | Tok_Type + | Tok_Subtype + | Tok_Constant + | Tok_Signal + | Tok_Variable + | Tok_Component + | Tok_Label => + null; + when Tok_Literal + | Tok_Units + | Tok_Group + | Tok_File => + null; + when others => + Error_Msg_Parse ("%t is not a entity class", +Current_Token); + end case; + Res := Current_Token; + Scan; + return Res; + end Parse_Entity_Class; + + function Parse_Entity_Class_Entry return Iir_Entity_Class + is + Res : Iir_Entity_Class; + begin + Res := Create_Iir (Iir_Kind_Entity_Class); + Set_Location (Res); + Set_Entity_Class (Res, Parse_Entity_Class); + return Res; + end Parse_Entity_Class_Entry; + + -- precond : next token + -- postcond: next token + -- + -- [ LRM93 5.1 ] + -- entity_designator ::= entity_tag [ signature ] + -- + -- entity_tag ::= simple_name | character_literal | operator_symbol + function Parse_Entity_Designator return Iir + is + Res : Iir; + Name : Iir; + begin + case Current_Token is + when Tok_Identifier => + Res := Create_Iir (Iir_Kind_Simple_Name); + Set_Location (Res); + Set_Identifier (Res, Current_Identifier); + when Tok_Character => + Res := Create_Iir (Iir_Kind_Character_Literal); + Set_Location (Res); + Set_Identifier (Res, Current_Identifier); + when Tok_String => + Res := Create_Iir (Iir_Kind_Operator_Symbol); + Set_Location (Res); + Set_Identifier (Res, Scan_To_Operator_Name (Get_Token_Location)); + when others => + Error_Msg_Parse ("identifier, character or string expected"); + return Create_Error_Node; + end case; + Scan; + if Current_Token = Tok_Left_Bracket then + Name := Res; + Res := Parse_Signature; + Set_Signature_Prefix (Res, Name); + end if; + return Res; + end Parse_Entity_Designator; + + -- precond : next token + -- postcond: IS + -- + -- [ LRM93 5.1 ] + -- entity_name_list ::= entity_designator { , entity_designator } + -- | OTHERS + -- | ALL + procedure Parse_Entity_Name_List + (Attribute : Iir_Attribute_Specification) + is + List : Iir_List; + Flist : Iir_Flist; + El : Iir; + begin + case Current_Token is + when Tok_All => + Flist := Iir_Flist_All; + + -- Skip 'all'. + Scan; + + when Tok_Others => + Flist := Iir_Flist_Others; + + -- Skip 'others'. + Scan; + + when others => + List := Create_Iir_List; + loop + El := Parse_Entity_Designator; + Append_Element (List, El); + exit when Current_Token /= Tok_Comma; + Scan; + end loop; + Flist := List_To_Flist (List); + end case; + Set_Entity_Name_List (Attribute, Flist); + if Current_Token = Tok_Colon then + Scan; + Set_Entity_Class (Attribute, Parse_Entity_Class); + else + Error_Msg_Parse + ("missing ':' and entity kind in attribute specification"); + end if; + end Parse_Entity_Name_List; + + -- precond : ATTRIBUTE + -- postcond: next token + -- + -- [ 4.4 ] + -- attribute_declaration ::= ATTRIBUTE identifier : type_mark ; + -- + -- [ 5.1 ] + -- attribute_specification ::= + -- ATTRIBUTE attribute_designator OF entity_specification + -- IS expression ; + -- + -- entity_specification ::= entity_name_list : entity_class + -- + function Parse_Attribute return Iir + is + Ident : Name_Id; + Res : Iir; + Designator : Iir; + Loc, Start_Loc : Location_Type; + begin + Start_Loc := Get_Token_Location; + + -- Eat 'attribute'. + pragma Assert (Current_Token = Tok_Attribute); + Scan; + + Loc := Get_Token_Location; + if Current_Token = Tok_Identifier then + Ident := Current_Identifier; + + -- Skip identifier. + Scan; + else + Expect (Tok_Identifier); + Ident := Null_Identifier; + end if; + + case Current_Token is + when Tok_Colon => + Res := Create_Iir (Iir_Kind_Attribute_Declaration); + Set_Location (Res, Loc); + Set_Identifier (Res, Ident); + + -- Skip ':'. + Scan; + + Set_Type_Mark (Res, Parse_Type_Mark (Check_Paren => True)); + Scan_Semi_Colon_Declaration ("attribute declaration"); + + when Tok_Of => + Res := Create_Iir (Iir_Kind_Attribute_Specification); + Set_Location (Res, Loc); + Designator := Create_Iir (Iir_Kind_Simple_Name); + Set_Location (Designator, Loc); + Set_Identifier (Designator, Ident); + Set_Attribute_Designator (Res, Designator); + + -- Skip 'of'. + Scan; + + Parse_Entity_Name_List (Res); + + -- Skip 'is'. + Expect_Scan (Tok_Is); + + Set_Expression (Res, Parse_Expression); + Scan_Semi_Colon_Declaration ("attribute specification"); + + when others => + Error_Msg_Parse ("':' or 'of' expected after identifier"); + return Null_Iir; + end case; + + if Flag_Elocations then + Create_Elocations (Res); + Set_Start_Location (Res, Start_Loc); + end if; + + return Res; + end Parse_Attribute; + + -- precond : GROUP + -- postcond: ';' + -- + -- [ LRM93 4.6 ] + -- group_template_declaration ::= + -- GROUP identifier IS (entity_class_entry_list) ; + -- + -- entity_class_entry_list ::= entity_class_entry { , entity_class_entry } + -- + -- entity_class_entry ::= entity_class [ <> ] + function Parse_Group return Iir + is + Loc : Location_Type; + Ident : Name_Id; + begin + -- Skip 'group'. + pragma Assert (Current_Token = Tok_Group); + Scan; + + Loc := Get_Token_Location; + if Current_Token = Tok_Identifier then + Ident := Current_Identifier; + + -- Skip 'group'. + Scan; + else + Ident := Null_Identifier; + Expect (Tok_Identifier); + end if; + + case Current_Token is + when Tok_Is => + declare + use Iir_Chains.Entity_Class_Entry_Chain_Handling; + Res : Iir_Group_Template_Declaration; + El : Iir_Entity_Class; + Last : Iir_Entity_Class; + begin + Res := Create_Iir (Iir_Kind_Group_Template_Declaration); + Set_Location (Res, Loc); + Set_Identifier (Res, Ident); + + -- Skip 'is'. + Scan; + + -- Skip '('. + Expect_Scan (Tok_Left_Paren); + + Build_Init (Last); + loop + Append (Last, Res, Parse_Entity_Class_Entry); + if Current_Token = Tok_Box then + El := Create_Iir (Iir_Kind_Entity_Class); + Set_Location (El); + Set_Entity_Class (El, Tok_Box); + Append (Last, Res, El); + + -- Skip '<>'. + Scan; + + if Current_Token = Tok_Comma then + Error_Msg_Parse + ("'<>' is allowed only for the last " + & "entity class entry"); + end if; + end if; + exit when Current_Token /= Tok_Comma; + + -- Skip ','. + Scan; + end loop; + + -- Skip ')' ';' + Expect_Scan (Tok_Right_Paren); + Scan_Semi_Colon_Declaration ("group template"); + + return Res; + end; + when Tok_Colon => + declare + Res : Iir_Group_Declaration; + List : Iir_List; + begin + Res := Create_Iir (Iir_Kind_Group_Declaration); + Set_Location (Res, Loc); + Set_Identifier (Res, Ident); + + -- Skip ':'. + Scan; + + Set_Group_Template_Name + (Res, Parse_Name (Allow_Indexes => False)); + + -- Skip '('. + Expect_Scan (Tok_Left_Paren); + + List := Create_Iir_List; + loop + Append_Element (List, Parse_Name (Allow_Indexes => False)); + exit when Current_Token /= Tok_Comma; + + -- Skip ','. + Scan; + end loop; + + -- Skip ')' ';'. + Expect_Scan (Tok_Right_Paren); + Scan_Semi_Colon_Declaration ("group declaration"); + + Set_Group_Constituent_List (Res, List_To_Flist (List)); + return Res; + end; + when others => + Error_Msg_Parse ("':' or 'is' expected here"); + return Null_Iir; + end case; + end Parse_Group; + + -- precond : next token + -- postcond: ':' + -- + -- [ LRM93 5.4 ] + -- signal_list ::= signal_name { , signal_name } + -- | OTHERS + -- | ALL + function Parse_Signal_List return Iir_Flist + is + Res : Iir_List; + begin + case Current_Token is + when Tok_Others => + -- Skip 'others'. + Scan; + + return Iir_Flist_Others; + + when Tok_All => + -- Skip 'all'. + Scan; + + return Iir_Flist_All; + + when others => + Res := Create_Iir_List; + loop + Append_Element (Res, Parse_Name); + exit when Current_Token /= Tok_Comma; + + -- Skip ',' + Scan; + end loop; + + return List_To_Flist (Res); + end case; + end Parse_Signal_List; + + -- precond : DISCONNECT + -- postcond: next token. + -- + -- [ LRM93 5.4 ] + -- disconnection_specification ::= + -- DISCONNECT guarded_signal_specification AFTER time_expression ; + function Parse_Disconnection_Specification + return Iir_Disconnection_Specification + is + Res : Iir_Disconnection_Specification; + begin + pragma Assert (Current_Token = Tok_Disconnect); + + Res := Create_Iir (Iir_Kind_Disconnection_Specification); + Set_Location (Res); + + -- Skip 'disconnect' + Scan; + + Set_Signal_List (Res, Parse_Signal_List); + + -- Skip ':' + Expect_Scan (Tok_Colon); + + Set_Type_Mark (Res, Parse_Type_Mark (Check_Paren => True)); + + -- Skip 'after' + Expect_Scan (Tok_After); + + Set_Expression (Res, Parse_Expression); + + -- Skip ';'. + Scan_Semi_Colon_Declaration ("disconnection specification"); + + return Res; + end Parse_Disconnection_Specification; + + -- Parse PSL clock_declaration at 'clock'. + function Parse_Psl_Default_Clock_Cont (Loc : Location_Type) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Psl_Default_Clock); + Set_Location (Res, Loc); + Xrefs.Xref_Keyword (Get_Token_Location); + + -- Recognize PSL keywords. + Vhdl.Scanner.Flag_Psl := True; + + -- Skip 'clock'. + Expect_Scan (Tok_Psl_Clock); + + -- Skip 'is'. + Expect_Scan (Tok_Is); + + Set_Psl_Boolean (Res, Parse_Psl.Parse_Psl_Boolean); + + Vhdl.Scanner.Flag_Scan_In_Comment := False; + Vhdl.Scanner.Flag_Psl := False; + + Expect_Scan (Tok_Semi_Colon); + + return Res; + end Parse_Psl_Default_Clock_Cont; + + -- 1850-2005 A.4.2 PSL declarations + -- clock_declaration ::= DEFAULT CLOCK IS clock_expression ; + function Parse_Psl_Default_Clock return Iir + is + Loc : Location_Type; + begin + Loc := Get_Token_Location; + + -- Recognize PSL keywords. + Vhdl.Scanner.Flag_Psl := True; + + -- Skip 'default'. + Scan; + + return Parse_Psl_Default_Clock_Cont (Loc); + end Parse_Psl_Default_Clock; + + function Parse_Psl_Declaration return Iir + is + Tok : constant Token_Type := Current_Token; + Loc : constant Location_Type := Get_Token_Location; + Res : Iir; + Decl : PSL_Node; + Id : Name_Id; + begin + -- Skip 'property', 'sequence' or 'endpoint'. + Scan; + + if Current_Token /= Tok_Identifier then + Error_Msg_Parse ("declaration name expected here"); + Id := Null_Identifier; + else + Id := Current_Identifier; + end if; + + -- Parse PSL declaration. + Vhdl.Scanner.Flag_Psl := True; + Decl := Parse_Psl.Parse_Psl_Declaration (Tok); + Vhdl.Scanner.Flag_Scan_In_Comment := False; + Vhdl.Scanner.Flag_Psl := False; + + Expect_Scan (Tok_Semi_Colon); + + if Tok = Tok_Psl_Endpoint + and then Parse_Psl.Is_Instantiated_Declaration (Decl) + then + -- Instantiated endpoint: make it visible from VHDL. + Res := Create_Iir (Iir_Kind_Psl_Endpoint_Declaration); + else + -- Otherwise, it will be visible only from PSL. + Res := Create_Iir (Iir_Kind_Psl_Declaration); + end if; + Set_Location (Res, Loc); + Set_Identifier (Res, Id); + Set_Psl_Declaration (Res, Decl); + + return Res; + end Parse_Psl_Declaration; + + -- Return the parent of a nested package. Used to check if some + -- declarations are allowed in a package. + function Get_Package_Parent (Decl : Iir) return Iir + is + Res : Iir; + Parent : Iir; + begin + Res := Decl; + loop + case Get_Kind (Res) is + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body => + Parent := Get_Parent (Res); + if Get_Kind (Parent) = Iir_Kind_Design_Unit then + return Res; + else + Res := Parent; + end if; + when others => + return Res; + end case; + end loop; + end Get_Package_Parent; + + -- precond : next token + -- postcond: next token + -- + -- [ LRM08 3.2.3 Entity declarative part ] + -- entity_declarative_item ::= + -- subprogram_declaration + -- | subprogram_body + -- | subprogram_instantiation_declaration + -- | package_declaration + -- | package_body + -- | package_instantiation_declaration + -- | type_declaration + -- | subtype_declaration + -- | constant_declaration + -- | signal_declaration + -- | shared_variable_declaration + -- | file_declaration + -- | alias_declaration + -- | attribute_declaration + -- | attribute_specification + -- | disconnection_specification + -- | use_clause + -- | group_template_declaration + -- | group_declaration + -- | PSL_property_declaration + -- | PSL_sequence_declaration + -- | PSL_clock_declaration + -- + -- [ LRM08 3.3.2 Architecture declarative part ] + -- block_declarative_item ::= + -- subprogram_declaration + -- | subprogram_body + -- | subprogram_instantiation_declaration + -- | package_declaration + -- | package_body + -- | package_instantiation_declaration + -- | type_declaration + -- | subtype_declaration + -- | constant_declaration + -- | signal_declaration + -- | shared_variable_declaration + -- | file_declaration + -- | alias_declaration + -- | component_declaration + -- | attribute_declaration + -- | attribute_specification + -- | configuration_specification + -- | disconnection_specification + -- | use_clause + -- | group_template_declaration + -- | group_declaration + -- | PSL_property_declaration + -- | PSL_sequence_declaration + -- | PSL_clock_declaration + -- + -- [ LRM08 4.3 Subprogram bodies ] + -- subprogram_declarative_item ::= + -- subprogram_declaration + -- | subprogram_body + -- | subprogram_instantiation_declaration + -- | package_declaration + -- | package_body + -- | package_instantiation_declaration + -- | type_declaration + -- | subtype_declaration + -- | constant_declaration + -- | variable_declaration + -- | file_declaration + -- | alias_declaration + -- | attribute_declaration + -- | attribute_specification + -- | use_clause + -- | group_template_declaration + -- | group_declaration + -- + -- [ LRM08 4.7 Package declarations ] + -- package_declarative_item ::= + -- subprogram_declaration + -- | subprogram_instantiation_declaration + -- | package_declaration + -- | package_instantiation_declaration + -- | type_declaration + -- | subtype_declaration + -- | constant_declaration + -- | signal_declaration + -- | variable_declaration + -- | file_declaraton + -- | alias_declaration + -- | component_declaration + -- | attribute_declaration + -- | attribute_specification + -- | disconnection_specification + -- | use_clause + -- | group_template_declaration + -- | group_declaration + -- | PSL_property_declaration + -- | PSL_sequence_declaration + -- + -- [ LRM08 4.8 Package bodies ] + -- package_body_declarative_item ::= + -- subprogram_declaration + -- | subprogram_body + -- | subprogram_instantiation_declaration + -- | package_declaration + -- | package_body + -- | package_instantiation_declaration + -- | type_declaration + -- | subtype_declaration + -- | constant_declaration + -- | variable_declaration + -- | file_declaration + -- | alias_declaration + -- | attribute_declaration + -- | attribute_specification + -- | use_clause + -- | group_template_declaration + -- | group_declaration + -- + -- [ LRM08 5.6.2 Protected type declarations ] + -- protected_type_declarative_item ::= + -- subprogram_declaration + -- | subprogram_instantiation_declaration + -- | attribute_specification + -- | use_clause + -- + -- [ LRM08 5.6.3 Protected type bodies ] + -- protected_type_body_declarative_item ::= + -- subprogram_declaration + -- | subprogram_body + -- | subprogram_instantiation_declaration + -- | package_declaration + -- | package_body + -- | package_instantiation_declaration + -- | type_declaration + -- | subtype_declaration + -- | constant_declaration + -- | variable_declaration + -- | file_declaration + -- | alias_declaration + -- | attribute_declaration + -- | attribute_specification + -- | use_clause + -- | group_template_declaration + -- | group_declaration + -- + -- [ LRM08 11.3 Process statement ] + -- process_declarative_item ::= + -- subprogram_declaration + -- | subprogram_body + -- | subprogram_instantiation_declaration + -- | package_declaration + -- | package_body + -- | package_instantiation_declaration + -- | type_declaration + -- | subtype_declaration + -- | constant_declaration + -- | variable_declaration + -- | file_declaration + -- | alias_declaration + -- | attribute_declaration + -- | attribute_specification + -- | use_clause + -- | group_template_declaration + -- | group_declaration + -- + -- Some declarations are not allowed in every declarative part: + -- - subprogram_body, package_body: + -- not in package_declaration + -- - signal_declaration, disconnection_specification: + -- not in process, protected_type_body, package_body, subprogram + -- - variable_declaration: + -- shared in entity, block (*) + -- not shared in subprogram, protected_type_body, process + -- depends on parent for package and package_body + -- - component_declaration: + -- not in entity, subprogram, package_body, protected_type_body, + -- process + -- depends on parent for package + -- - configuration_specification: + -- not in entity, subprogram, package, package_body, protected_type_body, + -- process + -- - PSL_property_declaration, PSL_sequence_declaration: + -- in entity and block (*) + -- depends on parent for package + -- - PSL_clock_declaration: + -- in block (*) + -- + -- Declarations for protected_type_declaration are handled in sem. + -- + -- (*): block means block_declarative_item, ie: block_statement, + -- architecture_body and generate_statement) + procedure Parse_Declarative_Part (Parent : Iir) + is + use Declaration_Chain_Handling; + Last_Decl : Iir; + Decl : Iir; + Package_Parent_Cache : Iir; + + function Package_Parent return Iir is + begin + if Package_Parent_Cache = Null_Iir then + Package_Parent_Cache := Get_Package_Parent (Parent); + end if; + return Package_Parent_Cache; + end Package_Parent; + begin + Package_Parent_Cache := Null_Iir; + Build_Init (Last_Decl); + loop + Decl := Null_Iir; + case Current_Token is + when Tok_Invalid => + raise Internal_Error; + when Tok_Type => + Decl := Parse_Type_Declaration (Parent); + + -- LRM 2.5 Package declarations + -- If a package declarative item is a type declaration that is + -- a full type declaration whose type definition is a + -- protected_type definition, then that protected type + -- definition must not be a protected type body. + if Decl /= Null_Iir + and then Get_Kind (Decl) = Iir_Kind_Protected_Type_Body + then + case Get_Kind (Parent) is + when Iir_Kind_Package_Declaration => + Error_Msg_Parse (+Decl, "protected type body not " + & "allowed in package declaration"); + when others => + null; + end case; + end if; + when Tok_Subtype => + Decl := Parse_Subtype_Declaration (Parent); + when Tok_Nature => + Decl := Parse_Nature_Declaration; + when Tok_Terminal => + Decl := Parse_Terminal_Declaration (Parent); + when Tok_Quantity => + Decl := Parse_Quantity_Declaration (Parent); + when Tok_Signal => + -- LRM08 4.7 Package declarations + -- For package declaration that appears in a subprogram body, + -- a process statement, or a protected type body, [...] + -- Moreover, it is an eror if [...] a signal declaration [...] + -- appears as a package declarative item of such a package + -- declaration. + case Get_Kind (Package_Parent) is + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Error_Msg_Parse + ("signal declaration not allowed in subprogram body"); + when Iir_Kinds_Process_Statement => + Error_Msg_Parse + ("signal declaration not allowed in process"); + when Iir_Kind_Protected_Type_Body + | Iir_Kind_Protected_Type_Declaration => + Error_Msg_Parse + ("signal declaration not allowed in protected type"); + when Iir_Kind_Package_Body => + Error_Msg_Parse + ("signal declaration not allowed in package body"); + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement_Body + | Iir_Kind_Package_Declaration => + null; + when others => + Error_Kind ("parse_declarative_part", Package_Parent); + end case; + Decl := Parse_Object_Declaration (Parent); + when Tok_Constant => + Decl := Parse_Object_Declaration (Parent); + when Tok_Variable => + -- LRM93 4.3.1.3 Variable declarations + -- Variable declared immediatly within entity declarations, + -- architectures bodies, packages, packages bodies, and blocks + -- must be shared variable. + -- Variables declared immediatly within subprograms and + -- processes must not be shared variables. + -- Variables may appear in protected type bodies; such + -- variables, which must not be shared variables, represent + -- shared data. + case Get_Kind (Package_Parent) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement_Body + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Protected_Type_Declaration => + -- FIXME: replace HERE with the kind of declaration + -- ie: "not allowed in a package" rather than "here". + Error_Msg_Parse + ("non-shared variable declaration not allowed here"); + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kinds_Process_Statement + | Iir_Kind_Protected_Type_Body => + null; + when others => + Error_Kind ("parse_declarative_part", Package_Parent); + end case; + Decl := Parse_Object_Declaration (Parent); + when Tok_Shared => + if Flags.Vhdl_Std <= Vhdl_87 then + Error_Msg_Parse ("shared variable not allowed in vhdl 87"); + end if; + -- LRM08 4.7 Package declarations + -- For package declaration that appears in a subprogram body, + -- a process statement, or a protected type body, it is an + -- error if a variable declaration in the package declaratie + -- part of the package declaration declares a shared variable. + + -- LRM08 4.8 Package bodies + -- For a package body that appears in a subprogram body, a + -- process statement or a protected type body, it is an error + -- if a variable declaration in the package body declarative + -- part of the package body declares a shared variable. + + -- LRM93 4.3.1.3 Variable declarations + -- Variable declared immediatly within entity declarations, + -- architectures bodies, packages, packages bodies, and blocks + -- must be shared variable. + -- Variables declared immediatly within subprograms and + -- processes must not be shared variables. + -- Variables may appear in proteted type bodies; such + -- variables, which must not be shared variables, represent + -- shared data. + case Get_Kind (Package_Parent) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement_Body + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Protected_Type_Declaration => + null; + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kinds_Process_Statement + | Iir_Kind_Protected_Type_Body => + Error_Msg_Parse + ("shared variable declaration not allowed here"); + when others => + Error_Kind ("parse_declarative_part", Package_Parent); + end case; + Decl := Parse_Object_Declaration (Parent); + when Tok_File => + Decl := Parse_Object_Declaration (Parent); + when Tok_Function + | Tok_Procedure + | Tok_Pure + | Tok_Impure => + Decl := Parse_Subprogram_Declaration; + if Decl /= Null_Iir + and then Get_Subprogram_Body (Decl) /= Null_Iir + then + if Get_Kind (Parent) = Iir_Kind_Package_Declaration then + Error_Msg_Parse + (+Decl, "subprogram body not allowed in a package"); + end if; + end if; + when Tok_Alias => + Decl := Parse_Alias_Declaration; + when Tok_Component => + case Get_Kind (Parent) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body + | Iir_Kinds_Process_Statement + | Iir_Kind_Package_Body + | Iir_Kind_Protected_Type_Body + | Iir_Kind_Protected_Type_Declaration => + Error_Msg_Parse + ("component declaration are not allowed here"); + when Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement_Body + | Iir_Kind_Package_Declaration => + null; + when others => + Error_Kind ("parse_declarative_part", Package_Parent); + end case; + Decl := Parse_Component_Declaration; + when Tok_For => + case Get_Kind (Parent) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kinds_Process_Statement + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Protected_Type_Body + | Iir_Kind_Protected_Type_Declaration => + Error_Msg_Parse + ("configuration specification not allowed here"); + when Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement_Body => + null; + when others => + Error_Kind ("parse_declarative_part", Package_Parent); + end case; + Decl := Parse_Configuration_Specification; + when Tok_Attribute => + Decl := Parse_Attribute; + when Tok_Disconnect => + -- LRM08 4.7 Package declarations + -- For package declaration that appears in a subprogram body, + -- a process statement, or a protected type body, [...] + -- Moreover, it is an eror if [...] a disconnection + -- specification [...] appears as a package declarative item + -- of such a package declaration. + case Get_Kind (Parent) is + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kinds_Process_Statement + | Iir_Kind_Protected_Type_Body + | Iir_Kind_Package_Body + | Iir_Kind_Protected_Type_Declaration => + Error_Msg_Parse + ("disconnect specification not allowed here"); + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement_Body + | Iir_Kind_Package_Declaration => + null; + when others => + Error_Kind ("parse_declarative_part", Parent); + end case; + Decl := Parse_Disconnection_Specification; + when Tok_Use => + Decl := Parse_Use_Clause; + when Tok_Group => + Decl := Parse_Group; + when Tok_Package => + if Vhdl_Std < Vhdl_08 then + Error_Msg_Parse + ("nested package not allowed before vhdl 2008"); + end if; + Decl := Parse_Package (Parent); + if Decl /= Null_Iir + and then Get_Kind (Decl) = Iir_Kind_Package_Body + then + if Get_Kind (Parent) = Iir_Kind_Package_Declaration then + Error_Msg_Parse + (+Decl, "package body not allowed in a package"); + end if; + end if; + + if Current_Token = Tok_Semi_Colon then + -- Skip ';'. + Scan; + end if; + when Tok_Identifier => + if Vhdl_Std >= Vhdl_08 + and then Current_Identifier = Name_Default + then + -- This identifier is a PSL keyword. + Xrefs.Xref_Keyword (Get_Token_Location); + + -- Check whether default clock are allowed in this region. + case Get_Kind (Parent) is + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body + | Iir_Kinds_Process_Statement + | Iir_Kind_Protected_Type_Body + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Protected_Type_Declaration => + Error_Msg_Parse + ("PSL default clock declaration not allowed here"); + when Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement_Body => + null; + when others => + Error_Kind ("parse_declarative_part", Parent); + end case; + Decl := Parse_Psl_Default_Clock; + else + Error_Msg_Parse + ("object class keyword such as 'variable' is expected"); + Resync_To_End_Of_Declaration; + end if; + when Tok_Semi_Colon => + Error_Msg_Parse ("';' (semi colon) not allowed alone"); + Scan; + when others => + exit; + end case; + if Decl /= Null_Iir then + Append_Subchain (Last_Decl, Parent, Decl); + end if; + end loop; + end Parse_Declarative_Part; + + -- precond : ENTITY + -- postcond: next token. + -- + -- [ LRM93 1.1 ] + -- entity_declaration ::= + -- ENTITY identifier IS + -- entiy_header + -- entity_declarative_part + -- [ BEGIN + -- entity_statement_part ] + -- END [ ENTITY ] [ ENTITY_simple_name ] + -- + -- [ LRM93 1.1.1 ] + -- entity_header ::= + -- [ FORMAL_generic_clause ] + -- [ FORMAL_port_clause ] + procedure Parse_Entity_Declaration (Unit : Iir_Design_Unit) + is + Res: Iir_Entity_Declaration; + Start_Loc : Location_Type; + Begin_Loc : Location_Type; + End_Loc : Location_Type; + begin + Expect (Tok_Entity); + Res := Create_Iir (Iir_Kind_Entity_Declaration); + Start_Loc := Get_Token_Location; + + if Flag_Elocations then + Create_Elocations (Res); + Set_Start_Location (Res, Start_Loc); + end if; + + -- Skip 'entity'. + pragma Assert (Current_Token = Tok_Entity); + Scan; + + -- Get identifier. + Scan_Identifier (Res); + + -- Skip 'is'. + Expect_Scan (Tok_Is); + + Parse_Generic_Port_Clauses (Res); + + Parse_Declarative_Part (Res); + + if Current_Token = Tok_Begin then + Begin_Loc := Get_Token_Location; + Set_Has_Begin (Res, True); + + -- Skip 'begin'. + Scan; + + Parse_Concurrent_Statements (Res); + else + Begin_Loc := No_Location; + end if; + + -- end keyword is expected to finish an entity declaration + End_Loc := Get_Token_Location; + Expect_Scan (Tok_End); + + if Current_Token = Tok_Entity then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("'entity' keyword not allowed here by vhdl 87"); + end if; + Set_End_Has_Reserved_Id (Res, True); + Scan; + end if; + Check_End_Name (Res); + Scan_Semi_Colon_Unit ("entity"); + + Set_Library_Unit (Unit, Res); + + if Flag_Elocations then + Set_Begin_Location (Res, Begin_Loc); + Set_End_Location (Res, End_Loc); + end if; + end Parse_Entity_Declaration; + + -- [ LRM93 7.3.2 ] + -- choice ::= simple_expression + -- | discrete_range + -- | ELEMENT_simple_name + -- | OTHERS + function Parse_A_Choice (Expr: Iir; Loc : Location_Type) return Iir + is + A_Choice: Iir; + Expr1: Iir; + begin + if Expr = Null_Iir then + if Current_Token = Tok_Others then + A_Choice := Create_Iir (Iir_Kind_Choice_By_Others); + Set_Location (A_Choice, Loc); + + -- Skip 'others' + Scan; + + return A_Choice; + else + Expr1 := Parse_Expression; + + if Expr1 = Null_Iir then + -- Handle parse error now. + -- FIXME: skip until '=>'. + A_Choice := Create_Iir (Iir_Kind_Choice_By_Expression); + Set_Location (A_Choice, Loc); + return A_Choice; + end if; + end if; + else + Expr1 := Expr; + end if; + + if Is_Range_Attribute_Name (Expr1) then + A_Choice := Create_Iir (Iir_Kind_Choice_By_Range); + Set_Choice_Range (A_Choice, Expr1); + elsif Current_Token = Tok_To or else Current_Token = Tok_Downto then + A_Choice := Create_Iir (Iir_Kind_Choice_By_Range); + Set_Choice_Range (A_Choice, Parse_Range_Expression (Expr1)); + else + A_Choice := Create_Iir (Iir_Kind_Choice_By_Expression); + Set_Choice_Expression (A_Choice, Expr1); + end if; + + Set_Location (A_Choice, Loc); + return A_Choice; + end Parse_A_Choice; + + -- [ LRM93 7.3.2 ] + -- choices ::= choice { | choice } + -- + -- Leave tok_double_arrow as current token. + procedure Parse_Choices (Expr: Iir; + First_Loc : Location_Type; + Chain : out Iir) + is + First, Last : Iir; + A_Choice: Iir; + Expr1 : Iir; + Loc : Location_Type; + begin + Sub_Chain_Init (First, Last); + Expr1 := Expr; + Loc := First_Loc; + loop + A_Choice := Parse_A_Choice (Expr1, Loc); + if First /= Null_Iir then + Set_Same_Alternative_Flag (A_Choice, True); + if Get_Kind (A_Choice) = Iir_Kind_Choice_By_Others then + Error_Msg_Parse ("'others' choice must be alone"); + end if; + end if; + + Sub_Chain_Append (First, Last, A_Choice); + + if Current_Token /= Tok_Bar then + Chain := First; + return; + end if; + Loc := Get_Token_Location; + + -- Skip '|'. + Scan; + + Expr1 := Null_Iir; + end loop; + end Parse_Choices; + + -- precond : '(' + -- postcond: next token + -- + -- This can be an expression or an aggregate. + -- + -- [ LRM93 7.3.2 ] + -- aggregate ::= ( element_association { , element_association } ) + -- + -- [ LRM93 7.3.2 ] + -- element_association ::= [ choices => ] expression + function Parse_Aggregate return Iir + is + use Iir_Chains.Association_Choices_Chain_Handling; + Expr: Iir; + Res: Iir; + Last : Iir; + Assoc: Iir; + Loc, Right_Loc : Location_Type; + begin + Loc := Get_Token_Location; + + -- Skip '(' + Scan; + + if Current_Token /= Tok_Others then + Expr := Parse_Expression; + case Current_Token is + when Tok_Comma + | Tok_Double_Arrow + | Tok_Bar => + -- This is really an aggregate + null; + when Tok_Right_Paren => + -- This was just a braced expression. + + Right_Loc := Get_Token_Location; + + -- Skip ')'. + Scan; + + if Expr /= Null_Iir + and then Get_Kind (Expr) = Iir_Kind_Aggregate + then + -- Parenthesis around aggregate is useless and change the + -- context for array aggregate. + Warning_Msg_Sem + (Warnid_Parenthesis, +Expr, + "suspicious parenthesis around aggregate"); + elsif not Flag_Parse_Parenthesis then + return Expr; + end if; + + -- Create a node for the parenthesis. + Res := Create_Iir (Iir_Kind_Parenthesis_Expression); + Set_Location (Res, Loc); + Set_Expression (Res, Expr); + + if Flag_Elocations then + Create_Elocations (Res); + Set_Right_Paren_Location (Res, Right_Loc); + end if; + + return Res; + + when Tok_Semi_Colon => + -- Surely a missing parenthesis. + -- FIXME: in case of multiple missing parenthesises, several + -- messages will be displayed + Error_Msg_Parse + ("missing ')' for opening parenthesis at %l", +Loc); + return Expr; + when others => + -- Surely a parse error... + null; + end case; + else + Expr := Null_Iir; + end if; + Res := Create_Iir (Iir_Kind_Aggregate); + Set_Location (Res, Loc); + Build_Init (Last); + loop + if Current_Token = Tok_Others then + Assoc := Parse_A_Choice (Null_Iir, Loc); + Expect (Tok_Double_Arrow); + + -- Eat '=>' + Scan; + + Expr := Parse_Expression; + else + -- Not others: an expression (or a range). + if Expr = Null_Iir then + Expr := Parse_Expression; + end if; + if Expr = Null_Iir then + return Null_Iir; + end if; + + case Current_Token is + when Tok_Comma + | Tok_Right_Paren => + Assoc := Create_Iir (Iir_Kind_Choice_By_None); + Set_Location (Assoc, Loc); + when others => + Parse_Choices (Expr, Loc, Assoc); + Expect (Tok_Double_Arrow); + + -- Eat '=>'. + Scan; + + Expr := Parse_Expression; + end case; + end if; + Set_Associated_Expr (Assoc, Expr); + Append_Subchain (Last, Res, Assoc); + exit when Current_Token /= Tok_Comma; + + Loc := Get_Token_Location; + + -- Eat ',' + Scan; + + Expr := Null_Iir; + end loop; + + -- Eat ')'. + Expect_Scan (Tok_Right_Paren); + return Res; + end Parse_Aggregate; + + -- precond : NEW + -- postcond: next token + -- + -- [LRM93 7.3.6] + -- allocator ::= NEW subtype_indication + -- | NEW qualified_expression + function Parse_Allocator return Iir + is + Loc: Location_Type; + Res : Iir; + Expr: Iir; + begin + Loc := Get_Token_Location; + + -- Accept 'new'. + Scan; + Expr := Parse_Name (Allow_Indexes => False); + if Expr /= Null_Iir + and then Get_Kind (Expr) /= Iir_Kind_Qualified_Expression + then + -- This is a subtype_indication. + Res := Create_Iir (Iir_Kind_Allocator_By_Subtype); + Expr := Parse_Subtype_Indication (Expr); + Set_Subtype_Indication (Res, Expr); + else + Res := Create_Iir (Iir_Kind_Allocator_By_Expression); + Set_Expression (Res, Expr); + end if; + + Set_Location (Res, Loc); + return Res; + end Parse_Allocator; + + -- precond : tok_bit_string + -- postcond: tok_bit_string + -- + -- Simply create the node for a bit string. + function Parse_Bit_String return Iir + is + Res : Iir; + B : Number_Base_Type; + begin + Res := Create_Iir (Iir_Kind_String_Literal8); + Set_Location (Res); + Set_String8_Id (Res, Current_String_Id); + Set_String_Length (Res, Current_String_Length); + case Get_Bit_String_Sign is + when 's' => + Set_Has_Sign (Res, True); + Set_Has_Signed (Res, True); + when 'u' => + Set_Has_Sign (Res, True); + Set_Has_Signed (Res, False); + when others => + Set_Has_Sign (Res, False); + Set_Has_Signed (Res, False); + end case; + + case Get_Bit_String_Base is + when 'b' => + B := Base_2; + when 'o' => + B := Base_8; + when 'd' => + B := Base_10; + when 'x' => + B := Base_16; + when others => + raise Internal_Error; + end case; + Set_Bit_String_Base (Res, B); + + return Res; + end Parse_Bit_String; + + -- Scan returns an expanded bit value. Adjust the expanded bit value as + -- required by the length. + procedure Resize_Bit_String (Lit : Iir; Nlen : Nat32) + is + use Str_Table; + + Old_Len : constant Nat32 := Get_String_Length (Lit); + Is_Signed : constant Boolean := Get_Has_Signed (Lit); + Id : constant String8_Id := Get_String8_Id (Lit); + C : Nat8; + begin + if Nlen > Old_Len then + -- Extend. + + -- LRM08 15.8 + -- -- If the length is greater than the number of characters in the + -- expanded bit value and the base specifier is B, UB, O, UO, X, + -- UX or D, the bit string value is obtained by concatenating a + -- string of 0 digits to the left of the expanded bit value. The + -- number of 0 digits in the string is such that the number of + -- characters in the result of the concatenation is the length of + -- the bit string literal. + -- + -- -- If the length is greater than the number of characters in the + -- expanded bit value and the base specifier is SB, SO or SX, the + -- bit string value is obtained by concatenating the the left of + -- the expanded bit value a string, each of whose characters is + -- the leftmost character of the expanded bit value. The number + -- of characters in the string is such that the number of + -- characters in the result of the concatenation is the length of + -- the bit string literal. + if Is_Signed then + if Old_Len = 0 then + Error_Msg_Parse + (+Lit, "cannot expand an empty signed bit string"); + C := Character'Pos ('0'); + else + C := Element_String8 (Id, 1); + end if; + else + C := Character'Pos ('0'); + end if; + Resize_String8 (Nlen); + -- Shift (position 1 is the MSB). + for I in reverse 1 .. Old_Len loop + Set_Element_String8 (Id, I + Nlen - Old_Len, + Element_String8 (Id, I)); + end loop; + for I in 1 .. Nlen - Old_Len loop + Set_Element_String8 (Id, I, C); + end loop; + Set_String_Length (Lit, Nlen); + + elsif Nlen < Old_Len then + -- Reduce. + + -- LRM08 15.8 + -- -- If the length is less than the number of characters in the + -- expanded bit value and the base specifier is B, UB, O, UO, X, + -- UX or D, the bit string value is obtained by deleting + -- sufficient characters from the left of the expanded bit value + -- to yield a string whose length is the length of the bit string + -- literal. It is an error if any of the character so deleted is + -- other than the digit 0. + -- + -- -- If the length is less than the number of characters in the + -- expanded bit value and the base specifier is SB, SO or SX, the + -- bit string value is obtained by deleting sufficient characters + -- from the left of the expanded bit value to yield a string whose + -- length is the length of the bit string literal. It is an error + -- if any of the characters so deleted differs from the leftmost + -- remaining character. + if Is_Signed then + C := Element_String8 (Id, 1 + Old_Len - Nlen); + else + C := Character'Pos ('0'); + end if; + for I in 1 .. Old_Len - Nlen loop + if Element_String8 (Id, I) /= C then + Error_Msg_Parse + (+Lit, "truncation of bit string changes the value"); + -- Avoid error storm. + exit; + end if; + end loop; + -- Shift (position 1 is the MSB). + for I in 1 .. Nlen loop + Set_Element_String8 (Id, I, + Element_String8 (Id, I + Old_Len - Nlen)); + end loop; + Resize_String8 (Nlen); + Set_String_Length (Lit, Nlen); + + else + -- LRM08 15.8 + -- -- If the length is equal to the number of characters in the + -- expanded bit value, the string literal value is the expanded + -- bit value itself. + null; + end if; + end Resize_Bit_String; + + -- Precond : next token after tok_integer + -- postcond: likewise + -- + -- Return an integer_literal or a physical_literal. + function Parse_Integer_Literal (Val : Iir_Int64) return Iir + is + Res : Iir; + begin + if Current_Token = Tok_Identifier then + -- physical literal + Res := Create_Iir (Iir_Kind_Physical_Int_Literal); + Set_Unit_Name (Res, Parse_Name (Allow_Indexes => False)); + else + -- integer literal + Res := Create_Iir (Iir_Kind_Integer_Literal); + end if; + Set_Value (Res, Val); + return Res; + end Parse_Integer_Literal; + + -- precond : next token + -- postcond: next token + -- + -- [ LRM93 7.1 ] + -- primary ::= name + -- | literal + -- | aggregate + -- | function_call + -- | qualified_expression + -- | type_conversion + -- | allocator + -- | ( expression ) + -- + -- [ LRM93 7.3.1 ] + -- literal ::= numeric_literal + -- | enumeration_literal + -- | string_literal + -- | bit_string_literal + -- | NULL + -- + -- [ LRM93 7.3.1 ] + -- numeric_literal ::= abstract_literal + -- | physical_literal + -- + -- [ LRM93 13.4 ] + -- abstract_literal ::= decimal_literal | based_literal + -- + -- [ LRM93 3.1.3 ] + -- physical_literal ::= [ abstract_literal ] UNIT_name + function Parse_Primary return Iir_Expression + is + Res: Iir_Expression; + Int: Iir_Int64; + Fp: Iir_Fp64; + Loc: Location_Type; + begin + case Current_Token is + when Tok_Integer => + Int := Current_Iir_Int64; + Loc := Get_Token_Location; + + -- Skip integer + Scan; + + Res := Parse_Integer_Literal (Int); + Set_Location (Res, Loc); + return Res; + + when Tok_Real => + Fp := Current_Iir_Fp64; + Loc := Get_Token_Location; + + -- Skip real + Scan; + + if Current_Token = Tok_Identifier then + -- physical literal + Res := Create_Iir (Iir_Kind_Physical_Fp_Literal); + Set_Unit_Name (Res, Parse_Name (Allow_Indexes => False)); + else + -- real literal + Res := Create_Iir (Iir_Kind_Floating_Point_Literal); + end if; + Set_Location (Res, Loc); + Set_Fp_Value (Res, Fp); + return Res; + + when Tok_Identifier + | Tok_Double_Less => + Res := Parse_Name (Allow_Indexes => True); + if Res /= Null_Iir + and then Get_Kind (Res) = Iir_Kind_Signature then + Error_Msg_Parse (+Res, "signature not allowed in expression"); + return Get_Signature_Prefix (Res); + else + return Res; + end if; + + when Tok_Character => + Res := Current_Text; + Scan; + if Current_Token = Tok_Tick then + Error_Msg_Parse + ("prefix of an attribute can't be a character literal"); + -- skip tick. + Scan; + -- skip attribute designator + Scan; + end if; + return Res; + when Tok_Left_Paren => + if Parenthesis_Depth = Max_Parenthesis_Depth then + Error_Msg_Parse + ("too many open parenthesis, skip to the matching one"); + Skip_Until_Closing_Parenthesis; + return Null_Iir; + else + Parenthesis_Depth := Parenthesis_Depth + 1; + Res := Parse_Aggregate; + Parenthesis_Depth := Parenthesis_Depth - 1; + return Res; + end if; + when Tok_String => + return Parse_Name; + when Tok_Null => + Res := Create_Iir (Iir_Kind_Null_Literal); + Set_Location (Res); + Scan; + return Res; + when Tok_New => + return Parse_Allocator; + + when Tok_Integer_Letter => + Int := Current_Iir_Int64; + Loc := Get_Token_Location; + + -- Skip integer + Scan; + + if Current_Token = Tok_Bit_String then + Res := Parse_Bit_String; + Set_Has_Length (Res, True); + + -- Skip bit string + Scan; + + -- Resize. + Resize_Bit_String (Res, Nat32 (Int)); + else + Error_Msg_Parse + (Get_Token_Location, + "space is required between number and unit name"); + Res := Parse_Integer_Literal (Int); + end if; + Set_Location (Res, Loc); + return Res; + + when Tok_Bit_String => + Res := Parse_Bit_String; + + -- Skip bit string + Scan; + + return Res; + + when Tok_Minus + | Tok_Plus => + Error_Msg_Parse + ("'-' and '+' are not allowed in primary, use parenthesis"); + return Parse_Expression (Prio_Simple); + + when Tok_Comma + | Tok_Semi_Colon + | Tok_Right_Paren + | Tok_Eof + | Tok_End => + -- Token not to be skipped + Error_Msg_Parse ("primary expression expected"); + return Create_Error_Node; + + when others => + Unexpected ("primary"); + return Create_Error_Node; + end case; + end Parse_Primary; + + -- [ LRM08 9 Expressions ] + -- + -- expression ::= + -- condition_operator primary + -- | logical_expression + -- + -- logical_expression ::= + -- relation { and relation } + -- | relation { or relation } + -- | relation { xor relation } + -- | relation [ nand relation ] + -- | relation [ nor relation ] + -- | relation { xnor relation } + -- + -- relation ::= + -- shift_expression [ relational_operator shift_expression ] + -- + -- shift_expression ::= + -- simple_expression [ shift_operator simple_expression ] + -- + -- simple_expression ::= + -- [ sign ] term { adding_operator term } + -- + -- term ::= + -- factor { multiplying_operator factor } + -- + -- factor ::= + -- primary [ ** primary ] + -- | abs primary + -- | not primary + -- | logical_operator primary + function Build_Unary_Factor (Op : Iir_Kind) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Op); + Set_Location (Res); + + -- Skip operator. + Scan; + + Set_Operand (Res, Parse_Primary); + + return Res; + end Build_Unary_Factor; + + function Build_Unary_Simple (Op : Iir_Kind) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Op); + Set_Location (Res); + + -- Skip operator. + Scan; + + Set_Operand (Res, Parse_Expression (Prio_Term)); + + return Res; + end Build_Unary_Simple; + + function Build_Unary_Factor_08 (Op : Iir_Kind) return Iir is + begin + if Flags.Vhdl_Std < Vhdl_08 then + Error_Msg_Parse ("missing left operand of logical expression"); + + -- Skip operator + Scan; + + return Parse_Primary; + else + return Build_Unary_Factor (Op); + end if; + end Build_Unary_Factor_08; + + function Parse_Unary_Expression return Iir + is + Res, Left : Iir_Expression; + begin + case Current_Token is + when Tok_Plus => + return Build_Unary_Simple (Iir_Kind_Identity_Operator); + when Tok_Minus => + return Build_Unary_Simple (Iir_Kind_Negation_Operator); + + when Tok_Abs => + return Build_Unary_Factor (Iir_Kind_Absolute_Operator); + when Tok_Not => + return Build_Unary_Factor (Iir_Kind_Not_Operator); + + when Tok_And => + return Build_Unary_Factor_08 (Iir_Kind_Reduction_And_Operator); + when Tok_Or => + return Build_Unary_Factor_08 (Iir_Kind_Reduction_Or_Operator); + when Tok_Nand => + return Build_Unary_Factor_08 (Iir_Kind_Reduction_Nand_Operator); + when Tok_Nor => + return Build_Unary_Factor_08 (Iir_Kind_Reduction_Nor_Operator); + when Tok_Xor => + return Build_Unary_Factor_08 (Iir_Kind_Reduction_Xor_Operator); + when Tok_Xnor => + return Build_Unary_Factor_08 (Iir_Kind_Reduction_Xnor_Operator); + + when others => + Left := Parse_Primary; + if Current_Token = Tok_Double_Star then + Res := Create_Iir (Iir_Kind_Exponentiation_Operator); + Set_Location (Res); + + -- Skip '**'. + Scan; + + Set_Left (Res, Left); + Set_Right (Res, Parse_Primary); + return Res; + else + return Left; + end if; + end case; + end Parse_Unary_Expression; + + -- Example: When PRIO is Prio_Simple, a simple expression will be returned. + function Parse_Binary_Expression (Left : Iir; Prio : Prio_Type) return Iir + is + Res : Iir; + Expr : Iir; + Op : Iir_Kind; + Op_Prio : Prio_Type; + Op_Tok : Token_Type; + begin + Res := Left; + loop + Op_Tok := Current_Token; + case Op_Tok is + when Tok_Star => + Op := Iir_Kind_Multiplication_Operator; + Op_Prio := Prio_Term; + when Tok_Slash => + Op := Iir_Kind_Division_Operator; + Op_Prio := Prio_Term; + when Tok_Mod => + Op := Iir_Kind_Modulus_Operator; + Op_Prio := Prio_Term; + when Tok_Rem => + Op := Iir_Kind_Remainder_Operator; + Op_Prio := Prio_Term; + + when Tok_Plus => + Op := Iir_Kind_Addition_Operator; + Op_Prio := Prio_Simple; + when Tok_Minus => + Op := Iir_Kind_Substraction_Operator; + Op_Prio := Prio_Simple; + when Tok_Ampersand => + Op := Iir_Kind_Concatenation_Operator; + Op_Prio := Prio_Simple; + + when Tok_Sll => + Op := Iir_Kind_Sll_Operator; + Op_Prio := Prio_Shift; + when Tok_Sla => + Op := Iir_Kind_Sla_Operator; + Op_Prio := Prio_Shift; + when Tok_Srl => + Op := Iir_Kind_Srl_Operator; + Op_Prio := Prio_Shift; + when Tok_Sra => + Op := Iir_Kind_Sra_Operator; + Op_Prio := Prio_Shift; + when Tok_Rol => + Op := Iir_Kind_Rol_Operator; + Op_Prio := Prio_Shift; + when Tok_Ror => + Op := Iir_Kind_Ror_Operator; + Op_Prio := Prio_Shift; + + when Tok_Equal => + Op := Iir_Kind_Equality_Operator; + Op_Prio := Prio_Relation; + when Tok_Not_Equal => + Op := Iir_Kind_Inequality_Operator; + Op_Prio := Prio_Relation; + when Tok_Less => + Op := Iir_Kind_Less_Than_Operator; + Op_Prio := Prio_Relation; + when Tok_Less_Equal => + Op := Iir_Kind_Less_Than_Or_Equal_Operator; + Op_Prio := Prio_Relation; + when Tok_Greater => + Op := Iir_Kind_Greater_Than_Operator; + Op_Prio := Prio_Relation; + when Tok_Greater_Equal => + Op := Iir_Kind_Greater_Than_Or_Equal_Operator; + Op_Prio := Prio_Relation; + when Tok_Match_Equal => + Op := Iir_Kind_Match_Equality_Operator; + Op_Prio := Prio_Relation; + when Tok_Match_Not_Equal => + Op := Iir_Kind_Match_Inequality_Operator; + Op_Prio := Prio_Relation; + when Tok_Match_Less => + Op := Iir_Kind_Match_Less_Than_Operator; + Op_Prio := Prio_Relation; + when Tok_Match_Less_Equal => + Op := Iir_Kind_Match_Less_Than_Or_Equal_Operator; + Op_Prio := Prio_Relation; + when Tok_Match_Greater => + Op := Iir_Kind_Match_Greater_Than_Operator; + Op_Prio := Prio_Relation; + when Tok_Match_Greater_Equal => + Op := Iir_Kind_Match_Greater_Than_Or_Equal_Operator; + Op_Prio := Prio_Relation; + + when Tok_And => + Op := Iir_Kind_And_Operator; + Op_Prio := Prio_Logical; + when Tok_Or => + Op := Iir_Kind_Or_Operator; + Op_Prio := Prio_Logical; + when Tok_Xor => + Op := Iir_Kind_Xor_Operator; + Op_Prio := Prio_Logical; + when Tok_Nand => + Op := Iir_Kind_Nand_Operator; + Op_Prio := Prio_Logical; + when Tok_Nor => + Op := Iir_Kind_Nor_Operator; + Op_Prio := Prio_Logical; + when Tok_Xnor => + Op := Iir_Kind_Xnor_Operator; + Op_Prio := Prio_Logical; + + when others => + return Res; + end case; + + -- If the OP_PRIO is less than PRIO, the binary operator will apply + -- to the whole expression. + -- eg: A * B + C + if Op_Prio < Prio then + return Res; + end if; + + Expr := Create_Iir (Op); + Set_Location (Expr); + Set_Left (Expr, Res); + + -- Skip operator. + Scan; + + -- Catch errors for Ada programmers. + if Current_Token = Tok_Then or Current_Token = Tok_Else then + Error_Msg_Parse ("""or else"" and ""and then"" sequences " + & "are not allowed in vhdl", Cont => True); + Error_Msg_Parse ("""and"" and ""or"" are short-circuit " + & "operators for BIT and BOOLEAN types"); + Scan; + end if; + + if Op_Prio >= Prio_Simple and then Current_Token in Token_Sign_Type + then + Error_Msg_Parse ("'-'/'+' can only appear before the first term"); + end if; + + -- Left association: A + B + C is (A + B) + C + Set_Right (Expr, Parse_Expression (Prio_Type'Succ (Op_Prio))); + Res := Expr; + + -- Only one relational_operator or shift_operator. + if Op_Prio = Prio_Relation then + if Current_Token in Token_Relational_Operator_Type then + Error_Msg_Parse + ("use parenthesis for consecutive relational expressions"); + end if; + elsif Op_Prio = Prio_Shift then + -- Only one shift_operator. + if Current_Token in Token_Shift_Operator_Type then + Error_Msg_Parse + ("use parenthesis for consecutive shift expressions"); + end if; + elsif Op_Prio = Prio_Logical then + if Current_Token = Op_Tok then + if Op_Tok = Tok_Nand or Op_Tok = Tok_Nor then + Error_Msg_Parse + ("sequence of 'nor' or 'nand' not allowed", Cont => True); + Error_Msg_Parse + ("('nor' and 'nand' are not associative)"); + end if; + elsif Current_Token in Token_Logical_Type then + -- Expression is a sequence of relations, with the same + -- operator. + Error_Msg_Parse ("only one type of logical operators may be " + & "used to combine relation"); + end if; + end if; + end loop; + end Parse_Binary_Expression; + + function Parse_Expression (Prio : Prio_Type := Prio_Expression) return Iir + is + Left : Iir; + Res : Iir; + begin + if Current_Token = Tok_Condition then + if Prio /= Prio_Expression then + Error_Msg_Parse + ("'??' must be the first operator of an expression"); + end if; + Res := Create_Iir (Iir_Kind_Condition_Operator); + Set_Location (Res); + + -- Skip '??' + Scan; + + Set_Operand (Res, Parse_Primary); + else + Left := Parse_Unary_Expression; + Res := Parse_Binary_Expression (Left, Prio); + end if; + + return Res; + end Parse_Expression; + + -- precond : next token + -- postcond: next token. + -- + -- [ 8.4 ] + -- waveform ::= waveform_element { , waveform_element } + -- | UNAFFECTED + -- + -- [ 8.4.1 ] + -- waveform_element ::= VALUE_expression [ AFTER TIME_expression ] + -- | NULL [ AFTER TIME_expression ] + function Parse_Waveform return Iir_Waveform_Element + is + Res: Iir_Waveform_Element; + We, Last_We : Iir_Waveform_Element; + begin + if Current_Token = Tok_Unaffected then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("'unaffected' is not allowed in vhdl87"); + end if; + + Res := Create_Iir (Iir_Kind_Unaffected_Waveform); + Set_Location (Res); + + -- Skip 'unaffected'. + Scan; + else + Sub_Chain_Init (Res, Last_We); + loop + We := Create_Iir (Iir_Kind_Waveform_Element); + Sub_Chain_Append (Res, Last_We, We); + Set_Location (We); + + -- Note: NULL is handled as a null_literal. + Set_We_Value (We, Parse_Expression); + + if Current_Token = Tok_After then + -- Skip 'after'. + Scan; + + Set_Time (We, Parse_Expression); + end if; + + exit when Current_Token /= Tok_Comma; + + -- Skip ','. + Scan; + end loop; + end if; + + return Res; + end Parse_Waveform; + + -- precond : next token + -- postcond: next token + -- + -- [ 8.4 ] + -- delay_mechanism ::= TRANSPORT + -- | [ REJECT TIME_expression ] INERTIAL + procedure Parse_Delay_Mechanism (Assign: Iir) is + begin + if Current_Token = Tok_Transport then + Set_Delay_Mechanism (Assign, Iir_Transport_Delay); + Scan; + else + Set_Delay_Mechanism (Assign, Iir_Inertial_Delay); + if Current_Token = Tok_Reject then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("'reject' delay mechanism not allowed in vhdl 87"); + end if; + Scan; + Set_Reject_Time_Expression (Assign, Parse_Expression); + Expect (Tok_Inertial); + Scan; + elsif Current_Token = Tok_Inertial then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("'inertial' keyword not allowed in vhdl 87"); + end if; + Scan; + end if; + end if; + end Parse_Delay_Mechanism; + + -- precond : next token + -- postcond: next token + -- + -- [ LRM93 9.5 ] + -- options ::= [ GUARDED ] [ delay_mechanism ] + procedure Parse_Options (Stmt : Iir) is + begin + if Current_Token = Tok_Guarded then + Set_Guard (Stmt, Stmt); + Scan; + end if; + Parse_Delay_Mechanism (Stmt); + end Parse_Options; + + -- precond : next tkoen + -- postcond: next token (';') + -- + -- [ LRM93 9.5.1 ] + -- conditional_waveforms ::= + -- { waveform WHEN condition ELSE } + -- waveform [ WHEN condition ] + function Parse_Conditional_Waveforms return Iir + is + Wf : Iir; + Res : Iir; + Cond_Wf, N_Cond_Wf : Iir_Conditional_Waveform; + begin + Wf := Parse_Waveform; + if Current_Token /= Tok_When then + return Wf; + else + Res := Create_Iir (Iir_Kind_Conditional_Waveform); + Set_Location (Res); + Set_Waveform_Chain (Res, Wf); + + Cond_Wf := Res; + loop + -- Skip 'when'. + Scan; + + Set_Condition (Cond_Wf, Parse_Expression); + + if Current_Token /= Tok_Else then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("else missing in vhdl 87"); + end if; + exit; + end if; + + N_Cond_Wf := Create_Iir (Iir_Kind_Conditional_Waveform); + Set_Location (N_Cond_Wf); + Set_Chain (Cond_Wf, N_Cond_Wf); + Cond_Wf := N_Cond_Wf; + + -- Eat 'else' + Scan; + + Set_Waveform_Chain (Cond_Wf, Parse_Waveform); + + exit when Current_Token /= Tok_When; + end loop; + return Res; + end if; + end Parse_Conditional_Waveforms; + + -- precond : '<=' (or ':=') + -- postcond: next token (after ';') + -- + -- [ LRM93 9.5.1 ] + -- concurrent_conditional_signal_assignment ::= + -- target <= [ GUARDED ] [ delay_mechanism ] conditional_waveforms ; + -- + -- [ LRM08 10.5.2.1 ] + -- concurrent_simple_waveform_assignment ::= + -- target <= [ GUARDED ] [ delay_mechanism ] waveform ; + function Parse_Concurrent_Conditional_Signal_Assignment (Target: Iir) + return Iir + is + Res: Iir; + Loc : Location_Type; + N_Res : Iir; + Wf : Iir; + begin + Loc := Get_Token_Location; + case Current_Token is + when Tok_Less_Equal => + -- Skip '<='. + Scan; + when Tok_Assign => + Error_Msg_Parse ("':=' not allowed in concurrent statement, " + & "replaced by '<='"); + -- Skip ':='. + Scan; + when others => + Expect (Tok_Less_Equal); + end case; + + -- Assume simple signal assignment. + Res := Create_Iir (Iir_Kind_Concurrent_Simple_Signal_Assignment); + Parse_Options (Res); + + Wf := Parse_Conditional_Waveforms; + if Wf /= Null_Iir + and then Get_Kind (Wf) = Iir_Kind_Conditional_Waveform + then + N_Res := + Create_Iir (Iir_Kind_Concurrent_Conditional_Signal_Assignment); + if Get_Guard (Res) /= Null_Iir then + Set_Guard (N_Res, N_Res); + end if; + Set_Delay_Mechanism (N_Res, Get_Delay_Mechanism (Res)); + Set_Reject_Time_Expression (N_Res, Get_Reject_Time_Expression (Res)); + Free_Iir (Res); + Res := N_Res; + Set_Conditional_Waveform_Chain (Res, Wf); + else + Set_Waveform_Chain (Res, Wf); + end if; + Set_Location (Res, Loc); + Set_Target (Res, Target); + Expect_Scan (Tok_Semi_Colon, "';' expected at end of signal assignment"); + + return Res; + end Parse_Concurrent_Conditional_Signal_Assignment; + + -- precond : WITH + -- postcond: next token + -- + -- [ LRM93 9.5.2 ] + -- selected_signal_assignment ::= + -- WITH expresion SELECT + -- target <= options selected_waveforms ; + -- + -- [ LRM93 9.5.2 ] + -- selected_waveforms ::= + -- { waveform WHEN choices , } + -- waveform WHEN choices + function Parse_Selected_Signal_Assignment return Iir + is + use Iir_Chains.Selected_Waveform_Chain_Handling; + Res : Iir; + Assoc : Iir; + Wf_Chain : Iir_Waveform_Element; + Target : Iir; + Last : Iir; + When_Loc : Location_Type; + begin + -- Skip 'with'. + Scan; + + Res := Create_Iir (Iir_Kind_Concurrent_Selected_Signal_Assignment); + Set_Location (Res); + Set_Expression (Res, Parse_Expression); + + Expect_Scan (Tok_Select, "'select' expected after expression"); + + if Current_Token = Tok_Left_Paren then + Target := Parse_Aggregate; + else + Target := Parse_Name (Allow_Indexes => True); + end if; + Set_Target (Res, Target); + Expect_Scan (Tok_Less_Equal); + + Parse_Options (Res); + + Build_Init (Last); + loop + Wf_Chain := Parse_Waveform; + Expect (Tok_When, "'when' expected after waveform"); + When_Loc := Get_Token_Location; + + -- Eat 'when'. + Scan; + + Parse_Choices (Null_Iir, When_Loc, Assoc); + Set_Associated_Chain (Assoc, Wf_Chain); + Append_Subchain (Last, Res, Assoc); + exit when Current_Token /= Tok_Comma; + -- Skip ','. + Scan; + end loop; + + Expect_Scan (Tok_Semi_Colon, "';' expected at end of signal assignment"); + + return Res; + end Parse_Selected_Signal_Assignment; + + -- precond : next token + -- postcond: next token. + -- + -- [ LRM93 8.1 ] + -- sensitivity_list ::= SIGNAL_name { , SIGNAL_name } + procedure Parse_Sensitivity_List (List: Iir_List) + is + El : Iir; + begin + loop + El := Parse_Name (Allow_Indexes => True); + if El /= Null_Iir then + case Get_Kind (El) is + when Iir_Kind_Simple_Name + | Iir_Kind_Parenthesis_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Attribute_Name + | Iir_Kind_Selected_By_All_Name + | Iir_Kind_Indexed_Name => + null; + when others => + Error_Msg_Parse + ("only names are allowed in a sensitivity list"); + El := Create_Error_Node (El); + end case; + Append_Element (List, El); + end if; + + exit when Current_Token /= Tok_Comma; + + -- Skip ','. + Scan; + end loop; + end Parse_Sensitivity_List; + + -- precond : ASSERT + -- postcond: next token + -- Note: this fill an sequential or a concurrent statement. + -- + -- [ LRM93 9.4 ] + -- concurrent_assertion_statement ::= + -- [ label : ] [ POSTPONED ] assertion ; + -- + -- [ LRM93 8.2 ] + -- assertion ::= ASSERT condition + -- [ REPORT expression ] [ SEVERITY expression ] + procedure Parse_Assertion (Stmt: Iir) is + begin + Set_Location (Stmt); + + -- Skip 'assert'. + Scan; + + Set_Assertion_Condition (Stmt, Parse_Expression); + + if Current_Token = Tok_Report then + -- Skip 'report'. + Scan; + + Set_Report_Expression (Stmt, Parse_Expression); + end if; + + if Current_Token = Tok_Severity then + -- Skip 'severity'. + Scan; + + Set_Severity_Expression (Stmt, Parse_Expression); + if Current_Token = Tok_Report then + -- Nice message in case of inversion. + Error_Msg_Parse + ("report expression must precede severity expression"); + Scan; + Set_Report_Expression (Stmt, Parse_Expression); + end if; + end if; + end Parse_Assertion; + + -- precond : REPORT + -- postcond: next token + -- + -- [ 8.3 ] + -- report_statement ::= REPORT expression [ SEVERITY expression ] + function Parse_Report_Statement return Iir_Report_Statement + is + Res : Iir_Report_Statement; + begin + Res := Create_Iir (Iir_Kind_Report_Statement); + Set_Location (Res); + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("report statement not allowed in vhdl87"); + end if; + + -- Skip 'report'. + Scan; + + Set_Report_Expression (Res, Parse_Expression); + + if Current_Token = Tok_Severity then + -- Skip 'severity'. + Scan; + + Set_Severity_Expression (Res, Parse_Expression); + end if; + return Res; + end Parse_Report_Statement; + + -- precond : WAIT + -- postcond: ';' + -- + -- [ LRM93 8.1 ] + -- wait_statement ::= + -- [ label : ] WAIT [ sensitivity_clause ] [ condition_clause ] + -- [ timeout_clause ] ; + -- + -- [ LRM93 8.1 ] + -- sensitivity_clause ::= ON sensitivity_list + -- + -- [ LRM93 8.1 ] + -- condition_clause ::= UNTIL conditiion + -- + -- [ LRM93 8.1 ] + -- timeout_clause ::= FOR TIME_expression + function Parse_Wait_Statement return Iir_Wait_Statement + is + Res: Iir_Wait_Statement; + List: Iir_List; + begin + Res := Create_Iir (Iir_Kind_Wait_Statement); + Set_Location (Res); + + -- Skip 'wait'. + Scan; + + -- Sensitivity clause. + case Current_Token is + when Tok_On => + List := Create_Iir_List; + Set_Sensitivity_List (Res, List); + Scan; + Parse_Sensitivity_List (List); + when Tok_Until => + null; + when Tok_For => + null; + when Tok_Semi_Colon => + return Res; + when others => + Error_Msg_Parse ("'on', 'until', 'for' or ';' expected"); + Resync_To_End_Of_Statement; + return Res; + end case; + + -- Condition clause. + case Current_Token is + when Tok_On => + Error_Msg_Parse ("only one sensitivity is allowed"); + Resync_To_End_Of_Statement; + return Res; + when Tok_Until => + Scan; + Set_Condition_Clause (Res, Parse_Expression); + when Tok_For => + null; + when Tok_Semi_Colon => + return Res; + when others => + Error_Msg_Parse ("'until', 'for' or ';' expected"); + Resync_To_End_Of_Statement; + return Res; + end case; + + -- Timeout clause. + case Current_Token is + when Tok_On => + Error_Msg_Parse ("only one sensitivity clause is allowed"); + Resync_To_End_Of_Statement; + return Res; + when Tok_Until => + Error_Msg_Parse ("only one condition clause is allowed"); + Resync_To_End_Of_Statement; + return Res; + when Tok_For => + Scan; + Set_Timeout_Clause (Res, Parse_Expression); + return Res; + when Tok_Semi_Colon => + return Res; + when others => + Error_Msg_Parse ("'for' or ';' expected"); + Resync_To_End_Of_Statement; + return Res; + end case; + end Parse_Wait_Statement; + + -- precond : IF + -- postcond: next token. + -- + -- [ LRM93 8.7 ] + -- if_statement ::= + -- [ IF_label : ] + -- IF condition THEN + -- sequence_of_statements + -- { ELSIF condition THEN + -- sequence_of_statements } + -- [ ELSE + -- sequence_of_statements ] + -- END IF [ IF_label ] ; + -- + -- FIXME: end label. + function Parse_If_Statement (Parent : Iir) return Iir_If_Statement + is + Res: Iir_If_Statement; + Clause: Iir; + N_Clause: Iir; + Start_Loc, Then_Loc, End_Loc : Location_Type; + begin + Res := Create_Iir (Iir_Kind_If_Statement); + Start_Loc := Get_Token_Location; + Set_Location (Res, Start_Loc); + Set_Parent (Res, Parent); + + -- Eat 'if'. + Scan; + + Clause := Res; + loop + Set_Condition (Clause, Parse_Expression); + Then_Loc := Get_Token_Location; + if Current_Token = Tok_Then then + -- Eat 'then'. + Scan; + else + Expect_Error (Tok_Then, "'then' is expected here"); + end if; + + Set_Sequential_Statement_Chain + (Clause, Parse_Sequential_Statements (Res)); + + End_Loc := Get_Token_Location; + + if Flag_Elocations then + Create_Elocations (Clause); + Set_Start_Location (Clause, Start_Loc); + Set_Then_Location (Clause, Then_Loc); + Set_End_Location (Clause, End_Loc); + end if; + + exit when Current_Token /= Tok_Else and Current_Token /= Tok_Elsif; + + N_Clause := Create_Iir (Iir_Kind_Elsif); + Start_Loc := Get_Token_Location; + Set_Location (N_Clause, Start_Loc); + Set_Else_Clause (Clause, N_Clause); + Clause := N_Clause; + if Current_Token = Tok_Else then + + -- Skip 'else'. + Scan; + + Set_Sequential_Statement_Chain + (Clause, Parse_Sequential_Statements (Res)); + + if Flag_Elocations then + Create_Elocations (Clause); + Set_Start_Location (Clause, Start_Loc); + Set_End_Location (Clause, Get_Token_Location); + end if; + + exit; + elsif Current_Token = Tok_Elsif then + -- Skip 'elsif'. + Scan; + else + raise Program_Error; + end if; + end loop; + + -- Skip 'end' 'if' + Expect_Scan (Tok_End); + Expect_Scan (Tok_If); + + return Res; + end Parse_If_Statement; + + function Parenthesis_Name_To_Procedure_Call (Name: Iir; Kind : Iir_Kind) + return Iir + is + Res: Iir; + Call : Iir_Procedure_Call; + Prefix : Iir; + begin + Res := Create_Iir (Kind); + if Name = Null_Iir then + Set_Location (Res); + return Res; + end if; + + Location_Copy (Res, Name); + Call := Create_Iir (Iir_Kind_Procedure_Call); + Location_Copy (Call, Name); + Set_Procedure_Call (Res, Call); + case Get_Kind (Name) is + when Iir_Kind_Parenthesis_Name => + Prefix := Get_Prefix (Name); + if Get_Kind (Prefix) = Iir_Kind_Operator_Symbol then + Error_Msg_Parse + (+Prefix, "operator cannot be used as procedure call"); + end if; + Set_Prefix (Call, Prefix); + Set_Parameter_Association_Chain + (Call, Get_Association_Chain (Name)); + Free_Iir (Name); + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Set_Prefix (Call, Name); + when Iir_Kind_String_Literal8 => + Error_Msg_Parse + ("string or operator cannot be used as procedure call"); + when Iir_Kind_Selected_By_All_Name + | Iir_Kind_Qualified_Expression + | Iir_Kind_Attribute_Name + | Iir_Kind_Operator_Symbol + | Iir_Kind_Signature => + Error_Msg_Parse + ("invalid name for a procedure call or missing assignment"); + when others => + Error_Kind ("parenthesis_name_to_procedure_call", Name); + end case; + return Res; + end Parenthesis_Name_To_Procedure_Call; + + -- precond : identifier + -- postcond: next token + -- + -- [ LRM93 8.9 ] + -- parameter_specification ::= identifier IN discrete_range + function Parse_Parameter_Specification (Parent : Iir) + return Iir_Iterator_Declaration + is + Decl : Iir_Iterator_Declaration; + begin + Decl := Create_Iir (Iir_Kind_Iterator_Declaration); + Set_Parent (Decl, Parent); + + -- Skip identifier + Scan_Identifier (Decl); + + -- Skip 'in' + Expect_Scan (Tok_In); + + Set_Discrete_Range (Decl, Parse_Discrete_Range); + return Decl; + end Parse_Parameter_Specification; + + -- precond: '<=' + -- postcond: next token + -- + -- [ LRM93 8.4 ] + -- signal_assignment_statement ::= + -- [ label : ] target <= [ delay_mechanism ] waveform ; + -- + -- [ LRM08 10.5 Signal assignment statement ] + -- signal_assignement_statement ::= + -- [ label : ] simple_signal_assignement + -- | [ label : ] conditional_signal_assignement + -- | [ label : ] selected_signal_assignement (TODO) + function Parse_Signal_Assignment_Statement (Target : Iir) return Iir + is + Stmt : Iir; + N_Stmt : Iir; + Wave_Chain : Iir; + begin + Stmt := Create_Iir (Iir_Kind_Simple_Signal_Assignment_Statement); + Set_Location (Stmt); + Set_Target (Stmt, Target); + + -- Skip '<='. + Scan; + + Parse_Delay_Mechanism (Stmt); + + Wave_Chain := Parse_Conditional_Waveforms; + + -- LRM 8.4 Signal assignment statement + -- It is an error is the reserved word UNAFFECTED appears as a + -- waveform in a (sequential) signal assignment statement. + if Get_Kind (Wave_Chain) = Iir_Kind_Unaffected_Waveform then + if Flags.Vhdl_Std < Vhdl_08 then + Error_Msg_Parse + ("'unaffected' is not allowed in a sequential statement"); + end if; + Set_Waveform_Chain (Stmt, Wave_Chain); + elsif Get_Kind (Wave_Chain) = Iir_Kind_Conditional_Waveform then + if Flags.Vhdl_Std < Vhdl_08 then + Error_Msg_Parse + ("conditional signal assignment not allowed in before vhdl08"); + end if; + N_Stmt := + Create_Iir (Iir_Kind_Conditional_Signal_Assignment_Statement); + Location_Copy (N_Stmt, Stmt); + Set_Target (N_Stmt, Target); + Set_Delay_Mechanism (N_Stmt, Get_Delay_Mechanism (Stmt)); + Set_Reject_Time_Expression + (N_Stmt, Get_Reject_Time_Expression (Stmt)); + Set_Conditional_Waveform_Chain (N_Stmt, Wave_Chain); + Free_Iir (Stmt); + Stmt := N_Stmt; + else + Set_Waveform_Chain (Stmt, Wave_Chain); + end if; + + return Stmt; + end Parse_Signal_Assignment_Statement; + + -- precond: WHEN + -- postcond: next token + -- + -- [ LRM08 10.5.3 Conditional signal assignments ] + -- conditional_expressions ::= + -- expression WHEN condition + -- { ELSE expression WHEN condition } + -- [ ELSE expression ] + function Parse_Conditional_Expression (Expr : Iir) return Iir + is + Res : Iir; + El, N_El : Iir; + begin + Res := Create_Iir (Iir_Kind_Conditional_Expression); + Set_Location (Res); + Set_Expression (Res, Expr); + El := Res; + + loop + -- Skip 'when'. + Scan; + + Set_Condition (El, Parse_Expression); + + exit when Current_Token /= Tok_Else; + + N_El := Create_Iir (Iir_Kind_Conditional_Expression); + Set_Location (N_El); + Set_Chain (El, N_El); + El := N_El; + + -- Skip 'else'. + Scan; + + Set_Expression (N_El, Parse_Expression); + + exit when Current_Token /= Tok_When; + end loop; + + return Res; + end Parse_Conditional_Expression; + + -- precond: ':=' + -- postcond: next token + -- + -- [ LRM93 8.5 ] + -- variable_assignment_statement ::= + -- [ label : ] target := expression ; + function Parse_Variable_Assignment_Statement (Target : Iir) return Iir + is + Stmt : Iir; + Loc : Location_Type; + Expr : Iir; + begin + Loc := Get_Token_Location; + + -- Skip ':='. + Scan; + + Expr := Parse_Expression; + + if Current_Token = Tok_When then + if Flags.Vhdl_Std < Vhdl_08 then + Error_Msg_Parse + ("conditional variable assignment not allowed before vhdl08"); + end if; + Stmt := + Create_Iir (Iir_Kind_Conditional_Variable_Assignment_Statement); + Set_Location (Stmt, Loc); + Set_Target (Stmt, Target); + Set_Conditional_Expression + (Stmt, Parse_Conditional_Expression (Expr)); + else + Stmt := Create_Iir (Iir_Kind_Variable_Assignment_Statement); + Set_Location (Stmt, Loc); + Set_Target (Stmt, Target); + Set_Expression (Stmt, Expr); + end if; + return Stmt; + end Parse_Variable_Assignment_Statement; + + -- precond: '<=', ':=' or ';' + -- postcond: next token + function Parse_Sequential_Assignment_Statement (Target : Iir) return Iir + is + Stmt : Iir; + Call : Iir; + begin + if Current_Token = Tok_Less_Equal then + return Parse_Signal_Assignment_Statement (Target); + elsif Current_Token = Tok_Assign then + return Parse_Variable_Assignment_Statement (Target); + elsif Current_Token = Tok_Semi_Colon then + return Parenthesis_Name_To_Procedure_Call + (Target, Iir_Kind_Procedure_Call_Statement); + else + Error_Msg_Parse + ("""<="" or "":="" expected instead of %t", +Current_Token); + Stmt := Create_Iir (Iir_Kind_Procedure_Call_Statement); + Call := Create_Iir (Iir_Kind_Procedure_Call); + Set_Prefix (Call, Target); + Set_Procedure_Call (Stmt, Call); + Set_Location (Call); + Resync_To_End_Of_Statement; + return Stmt; + end if; + end Parse_Sequential_Assignment_Statement; + + -- precond: CASE + -- postcond: ';' + -- + -- [ LRM93 8.8 ] + -- case_statement ::= + -- [ CASE_label : ] + -- CASE expression IS + -- case_statement_alternative + -- { case_statement_alternative } + -- END CASE [ CASE_label ] ; + -- + -- [ LRM93 8.8 ] + -- case_statement_alternative ::= WHEN choices => sequence_of_statements + function Parse_Case_Statement (Label : Name_Id) return Iir + is + use Iir_Chains.Case_Statement_Alternative_Chain_Handling; + Stmt : Iir; + Assoc: Iir; + Last_Assoc : Iir; + When_Loc : Location_Type; + begin + Stmt := Create_Iir (Iir_Kind_Case_Statement); + Set_Label (Stmt, Label); + Set_Location (Stmt); + + -- Skip 'case'. + Scan; + + Set_Expression (Stmt, Parse_Expression); + + -- Skip 'is'. + Expect (Tok_Is); + Scan; + + if Current_Token = Tok_End then + Error_Msg_Parse ("missing alternative in case statement"); + end if; + + Build_Init (Last_Assoc); + while Current_Token = Tok_When loop + When_Loc := Get_Token_Location; + + -- Skip 'when'. + Scan; + + Parse_Choices (Null_Iir, When_Loc, Assoc); + + -- Skip '=>'. + Expect_Scan (Tok_Double_Arrow); + + Set_Associated_Chain (Assoc, Parse_Sequential_Statements (Stmt)); + Append_Subchain (Last_Assoc, Stmt, Assoc); + end loop; + + if Flag_Elocations then + Create_Elocations (Stmt); + Set_End_Location (Stmt, Get_Token_Location); + end if; + + -- Skip 'end', 'case'. + Expect_Scan (Tok_End); + Expect_Scan (Tok_Case); + + if Flags.Vhdl_Std >= Vhdl_93c then + Check_End_Name (Stmt); + end if; + + return Stmt; + end Parse_Case_Statement; + + -- precond: FOR + -- postcond: ';' + -- + -- [ LRM93 8.9 ] + -- loop_statement ::= + -- [ LOOP_label : ] + -- [ iteration_scheme ] LOOP + -- sequence_of_statements + -- END LOOP [ LOOP_label ] ; + -- + -- [ LRM93 8.9 ] + -- iteration_scheme ::= WHILE condition + -- | FOR LOOP_parameter_specification + function Parse_For_Loop_Statement (Label : Name_Id) return Iir + is + Stmt : Iir; + Start_Loc, Loop_Loc, End_Loc : Location_Type; + begin + Stmt := Create_Iir (Iir_Kind_For_Loop_Statement); + Start_Loc := Get_Token_Location; + Set_Location (Stmt, Start_Loc); + Set_Label (Stmt, Label); + + -- Skip 'for' + Scan; + + Set_Parameter_Specification + (Stmt, Parse_Parameter_Specification (Stmt)); + + -- Skip 'loop' + Loop_Loc := Get_Token_Location; + Expect (Tok_Loop); + Scan; + + Set_Sequential_Statement_Chain + (Stmt, Parse_Sequential_Statements (Stmt)); + + -- Skip 'end' + End_Loc := Get_Token_Location; + Expect_Scan (Tok_End); + + -- Skip 'loop' + Expect_Scan (Tok_Loop); + + Check_End_Name (Stmt); + + if Flag_Elocations then + Create_Elocations (Stmt); + Set_Start_Location (Stmt, Start_Loc); + Set_Loop_Location (Stmt, Loop_Loc); + Set_End_Location (Stmt, End_Loc); + end if; + + return Stmt; + end Parse_For_Loop_Statement; + + -- precond: WHILE or LOOP + -- postcond: ';' + -- + -- [ 8.9 ] + -- loop_statement ::= + -- [ LOOP_label : ] + -- [ iteration_scheme ] LOOP + -- sequence_of_statements + -- END LOOP [ LOOP_label ] ; + function Parse_While_Loop_Statement (Label : Name_Id) return Iir + is + Stmt : Iir; + Start_Loc, Loop_Loc, End_Loc : Location_Type; + begin + Stmt := Create_Iir (Iir_Kind_While_Loop_Statement); + Start_Loc := Get_Token_Location; + Set_Location (Stmt, Start_Loc); + Set_Label (Stmt, Label); + if Current_Token = Tok_While then + -- Skip 'while'. + Scan; + + Set_Condition (Stmt, Parse_Expression); + Expect (Tok_Loop); + end if; + + -- Skip 'loop'. + Loop_Loc := Get_Token_Location; + Scan; + + Set_Sequential_Statement_Chain + (Stmt, Parse_Sequential_Statements (Stmt)); + + End_Loc := Get_Token_Location; + + -- Skip 'end'. + Expect_Scan (Tok_End); + + -- Skip 'loop'. + Expect_Scan (Tok_Loop); + + Check_End_Name (Stmt); + + if Flag_Elocations then + Create_Elocations (Stmt); + Set_Start_Location (Stmt, Start_Loc); + Set_Loop_Location (Stmt, Loop_Loc); + Set_End_Location (Stmt, End_Loc); + end if; + + return Stmt; + end Parse_While_Loop_Statement; + + -- precond: next token + -- postcond: next token + -- + -- [ LRM93 8 ] + -- sequence_of_statement ::= { sequential_statement } + -- + -- [ 8 ] + -- sequential_statement ::= wait_statement + -- | assertion_statement + -- | report_statement + -- | signal_assignment_statement + -- | variable_assignment_statement + -- | procedure_call_statement + -- | if_statement + -- | case_statement + -- | loop_statement + -- | next_statement + -- | exit_statement + -- | return_statement + -- | null_statement + -- + -- [ 8.13 ] + -- null_statement ::= [ label : ] NULL ; + -- + -- [ 8.12 ] + -- return_statement ::= [ label : ] RETURN [ expression ] + -- + -- [ 8.10 ] + -- next_statement ::= [ label : ] NEXT [ LOOP_label ] [ WHEN condition ] ; + -- + -- [ 8.11 ] + -- exit_statement ::= [ label : ] EXIT [ LOOP_label ] [ WHEN condition ] ; + -- + -- [ 8.9 ] + -- loop_statement ::= + -- [ LOOP_label : ] + -- [ iteration_scheme ] LOOP + -- sequence_of_statements + -- END LOOP [ LOOP_label ] ; + -- + -- [ 8.9 ] + -- iteration_scheme ::= WHILE condition + -- | FOR LOOP_parameter_specification + -- + -- [ 8.2 ] + -- assertion_statement ::= [ label : ] assertion ; + -- + -- [ 8.3 ] + -- report_statement ::= [ label : ] REPORT expression SEVERITY expression ; + function Parse_Sequential_Statements (Parent : Iir) + return Iir + is + First_Stmt : Iir; + Last_Stmt : Iir; + Stmt: Iir; + Label: Name_Id; + Loc : Location_Type; + Target : Iir; + begin + First_Stmt := Null_Iir; + Last_Stmt := Null_Iir; + -- Expect a current_token. + loop + Loc := Get_Token_Location; + if Current_Token = Tok_Identifier then + Label := Current_Identifier; + + -- Skip identifier. + Scan; + + if Current_Token = Tok_Colon then + -- Skip ':'. + Scan; + else + Target := Create_Iir (Iir_Kind_Simple_Name); + Set_Identifier (Target, Label); + Set_Location (Target, Loc); + Label := Null_Identifier; + Target := Parse_Name_Suffix (Target, True); + Stmt := Parse_Sequential_Assignment_Statement (Target); + goto Has_Stmt; + end if; + else + Label := Null_Identifier; + end if; + + case Current_Token is + when Tok_Null => + Stmt := Create_Iir (Iir_Kind_Null_Statement); + + -- Skip 'null'. + Scan; + + when Tok_Assert => + Stmt := Create_Iir (Iir_Kind_Assertion_Statement); + Parse_Assertion (Stmt); + when Tok_Report => + Stmt := Parse_Report_Statement; + when Tok_If => + Stmt := Parse_If_Statement (Parent); + Set_Label (Stmt, Label); + Set_Location (Stmt, Loc); + if Flags.Vhdl_Std >= Vhdl_93c then + Check_End_Name (Stmt); + end if; + when Tok_Case => + Stmt := Parse_Case_Statement (Label); + when Tok_Identifier + | Tok_String => + -- String for an expanded name with operator_symbol prefix. + Stmt := Parse_Sequential_Assignment_Statement (Parse_Name); + when Tok_Left_Paren => + declare + Target : Iir; + begin + Target := Parse_Aggregate; + if Current_Token = Tok_Less_Equal then + Stmt := Parse_Signal_Assignment_Statement (Target); + elsif Current_Token = Tok_Assign then + Stmt := Parse_Variable_Assignment_Statement (Target); + else + Error_Msg_Parse ("'<=' or ':=' expected"); + return First_Stmt; + end if; + end; + + when Tok_Return => + Stmt := Create_Iir (Iir_Kind_Return_Statement); + + -- Skip return. + Scan; + + if Current_Token /= Tok_Semi_Colon then + Set_Expression (Stmt, Parse_Expression); + end if; + + when Tok_For => + Stmt := Parse_For_Loop_Statement (Label); + Set_Location (Stmt, Loc); + + -- A loop statement can have a label, even in vhdl87. + Label := Null_Identifier; + + when Tok_While + | Tok_Loop => + Stmt := Parse_While_Loop_Statement (Label); + Set_Location (Stmt, Loc); + + -- A loop statement can have a label, even in vhdl87. + Label := Null_Identifier; + + when Tok_Next + | Tok_Exit => + if Current_Token = Tok_Next then + Stmt := Create_Iir (Iir_Kind_Next_Statement); + else + Stmt := Create_Iir (Iir_Kind_Exit_Statement); + end if; + + -- Skip 'next' or 'exit'. + Scan; + + if Current_Token = Tok_Identifier then + Set_Loop_Label (Stmt, Parse_Name (Allow_Indexes => False)); + end if; + + if Current_Token = Tok_When then + -- Skip 'when'. + Scan; + + Set_Condition (Stmt, Parse_Expression); + end if; + + when Tok_Wait => + Stmt := Parse_Wait_Statement; + + when Tok_Semi_Colon => + Error_Msg_Parse ("extra ';' ignored"); + + -- Eat ';' + Scan; + + goto Again; + when others => + return First_Stmt; + end case; + << Has_Stmt >> null; + Set_Parent (Stmt, Parent); + Set_Location (Stmt, Loc); + if Label /= Null_Identifier then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + (+Stmt, "this statement can't have a label in vhdl 87"); + else + Set_Label (Stmt, Label); + end if; + end if; + + if Current_Token = Tok_Semi_Colon then + -- Skip ';'. + Scan; + else + Error_Missing_Semi_Colon ("statement"); + Resync_To_End_Of_Statement; + if Current_Token = Tok_Semi_Colon then + -- Skip ';'. + Scan; + end if; + end if; + + -- Append it to the chain. + if First_Stmt = Null_Iir then + First_Stmt := Stmt; + else + Set_Chain (Last_Stmt, Stmt); + end if; + Last_Stmt := Stmt; + + <> null; + end loop; + end Parse_Sequential_Statements; + + -- precond : PROCEDURE, FUNCTION, PURE or IMPURE. + -- postcond: next token. + -- + -- [ LRM93 2.1 ] + -- subprogram_declaration ::= subprogram_specification ; + -- + -- [ LRM93 2.1 ] + -- subprogram_specification ::= + -- PROCEDURE designator [ ( formal_parameter_list ) ] + -- | [ PURE | IMPURE ] FUNCTION designator [ ( formal_parameter_list ) ] + -- RETURN type_mark + -- + -- [ LRM93 2.2 ] + -- subprogram_body ::= + -- subprogram_specification IS + -- subprogram_declarative_part + -- BEGIN + -- subprogram_statement_part + -- END [ subprogram_kind ] [ designator ] ; + -- + -- [ LRM93 2.1 ] + -- designator ::= identifier | operator_symbol + -- + -- [ LRM93 2.1 ] + -- operator_symbol ::= string_literal + function Parse_Subprogram_Declaration return Iir + is + Kind : Iir_Kind; + Subprg: Iir; + Subprg_Body : Iir; + Start_Loc, Is_Loc, Begin_Loc, End_Loc : Location_Type; + begin + -- Create the node. + Start_Loc := Get_Token_Location; + case Current_Token is + when Tok_Procedure => + Kind := Iir_Kind_Procedure_Declaration; + when Tok_Function + | Tok_Pure + | Tok_Impure => + Kind := Iir_Kind_Function_Declaration; + when others => + raise Internal_Error; + end case; + Subprg := Create_Iir (Kind); + Set_Location (Subprg); + Set_Implicit_Definition (Subprg, Iir_Predefined_None); + + case Current_Token is + when Tok_Procedure => + null; + when Tok_Function => + -- LRM93 2.1 + -- A function is impure if its specification contains the + -- reserved word IMPURE; otherwise it is said to be pure. + Set_Pure_Flag (Subprg, True); + when Tok_Pure + | Tok_Impure => + Set_Pure_Flag (Subprg, Current_Token = Tok_Pure); + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("'pure' and 'impure' are not allowed in vhdl 87"); + end if; + Set_Has_Pure (Subprg, True); + -- FIXME: what to do in case of error ?? + + -- Eat 'pure' or 'impure'. + Scan; + + Expect (Tok_Function, "'function' must follow 'pure' or 'impure'"); + when others => + raise Internal_Error; + end case; + + -- Eat 'procedure' or 'function'. + Scan; + + -- Designator. + Parse_Subprogram_Designator (Subprg); + + Parse_Subprogram_Parameters_And_Return + (Subprg, Kind = Iir_Kind_Function_Declaration); + + if Flag_Elocations then + Create_Elocations (Subprg); + Set_Start_Location (Subprg, Start_Loc); + end if; + + if Current_Token /= Tok_Is then + -- Skip ';'. + Expect_Scan (Tok_Semi_Colon); + + return Subprg; + end if; + + -- Skip 'is'. + Is_Loc := Get_Token_Location; + Scan; + + -- The body. + Set_Has_Body (Subprg, True); + if Kind = Iir_Kind_Function_Declaration then + Subprg_Body := Create_Iir (Iir_Kind_Function_Body); + else + Subprg_Body := Create_Iir (Iir_Kind_Procedure_Body); + end if; + Location_Copy (Subprg_Body, Subprg); + + Set_Subprogram_Body (Subprg, Subprg_Body); + Set_Subprogram_Specification (Subprg_Body, Subprg); + Set_Chain (Subprg, Subprg_Body); + + Parse_Declarative_Part (Subprg_Body); + + -- Skip 'begin'. + Begin_Loc := Get_Token_Location; + Expect_Scan (Tok_Begin); + + Set_Sequential_Statement_Chain + (Subprg_Body, Parse_Sequential_Statements (Subprg_Body)); + + -- Skip 'end'. + End_Loc := Get_Token_Location; + Expect_Scan (Tok_End); + + if Flag_Elocations then + Create_Elocations (Subprg_Body); + Set_Is_Location (Subprg_Body, Is_Loc); + Set_Begin_Location (Subprg_Body, Begin_Loc); + Set_End_Location (Subprg_Body, End_Loc); + end if; + + case Current_Token is + when Tok_Function => + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("'function' not allowed here by vhdl 87"); + end if; + if Kind = Iir_Kind_Procedure_Declaration then + Error_Msg_Parse ("'procedure' expected instead of 'function'"); + end if; + Set_End_Has_Reserved_Id (Subprg_Body, True); + + -- Skip 'function'. + Scan; + + when Tok_Procedure => + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("'procedure' not allowed here by vhdl 87"); + end if; + if Kind = Iir_Kind_Function_Declaration then + Error_Msg_Parse ("'function' expected instead of 'procedure'"); + end if; + Set_End_Has_Reserved_Id (Subprg_Body, True); + + -- Skip 'procedure' + Scan; + + when others => + null; + end case; + case Current_Token is + when Tok_Identifier => + Check_End_Name (Get_Identifier (Subprg), Subprg_Body); + when Tok_String => + if Scan_To_Operator_Name (Get_Token_Location) + /= Get_Identifier (Subprg) + then + Error_Msg_Parse ("misspelling, %i expected", +Subprg); + end if; + Set_End_Has_Identifier (Subprg_Body, True); + + -- Skip string. + Scan; + + when others => + null; + end case; + Scan_Semi_Colon_Declaration ("subprogram body"); + + return Subprg; + end Parse_Subprogram_Declaration; + + -- precond: PROCESS + -- postcond: next token + -- + -- [ LRM87 9.2 / LRM08 11.3 ] + -- process_statement ::= + -- [ PROCESS_label : ] + -- [ POSTPONED ] PROCESS [ ( process_sensitivity_list ) ] [ IS ] + -- process_declarative_part + -- BEGIN + -- process_statement_part + -- END [ POSTPONED ] PROCESS [ PROCESS_label ] ; + -- + -- process_sensitivity_list ::= ALL | sensitivity_list + function Parse_Process_Statement + (Label: Name_Id; Loc : Location_Type; Is_Postponed : Boolean) + return Iir + is + Res: Iir; + Sensitivity_List : Iir_List; + Start_Loc, Begin_Loc, End_Loc : Location_Type; + begin + Start_Loc := Get_Token_Location; + + -- Skip 'process' + Scan; + + if Current_Token = Tok_Left_Paren then + Res := Create_Iir (Iir_Kind_Sensitized_Process_Statement); + + -- Skip '(' + Scan; + + if Current_Token = Tok_All then + if Vhdl_Std < Vhdl_08 then + Error_Msg_Parse + ("all sensitized process allowed only in vhdl 08"); + end if; + Sensitivity_List := Iir_List_All; + + -- Skip 'all' + Scan; + else + Sensitivity_List := Create_Iir_List; + Parse_Sensitivity_List (Sensitivity_List); + end if; + Set_Sensitivity_List (Res, Sensitivity_List); + + -- Skip ')' + Expect (Tok_Right_Paren); + Scan; + else + Res := Create_Iir (Iir_Kind_Process_Statement); + end if; + + Set_Location (Res, Loc); + Set_Label (Res, Label); + Set_Has_Label (Res, Label /= Null_Identifier); + + if Current_Token = Tok_Is then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("""is"" not allowed here by vhdl 87"); + end if; + Set_Has_Is (Res, True); + + -- Skip 'is' + Scan; + end if; + + -- declarative part. + Parse_Declarative_Part (Res); + + -- Skip 'begin'. + Begin_Loc := Get_Token_Location; + Expect_Scan (Tok_Begin); + + Set_Sequential_Statement_Chain (Res, Parse_Sequential_Statements (Res)); + + -- Skip 'end'. + End_Loc := Get_Token_Location; + Expect_Scan (Tok_End); + + if Current_Token = Tok_Postponed then + if not Is_Postponed then + -- LRM93 9.2 + -- If the reserved word POSTPONED appears at the end of a process + -- statement, the process must be a postponed process. + Error_Msg_Parse ("process is not a postponed process"); + end if; + + Set_End_Has_Postponed (Res, True); + + -- Skip 'postponed', + Scan; + end if; + + if Current_Token = Tok_Semi_Colon then + Error_Msg_Parse ("""end"" must be followed by ""process"""); + + -- Skip ';'. + Scan; + else + Expect_Scan (Tok_Process); + Set_End_Has_Reserved_Id (Res, True); + Check_End_Name (Res); + Expect_Scan (Tok_Semi_Colon, "';' expected at end of process"); + end if; + + if Flag_Elocations then + Create_Elocations (Res); + Set_Start_Location (Res, Start_Loc); + Set_Begin_Location (Res, Begin_Loc); + Set_End_Location (Res, End_Loc); + end if; + + return Res; + end Parse_Process_Statement; + + function Check_Formal_Form (Formal : Iir) return Iir is + begin + if Formal = Null_Iir then + return Formal; + end if; + + case Get_Kind (Formal) is + when Iir_Kind_Simple_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Selected_Name => + return Formal; + when Iir_Kind_Parenthesis_Name => + -- Could be an indexed name, so nothing to check within the + -- parenthesis. + declare + Assoc : constant Iir := Get_Association_Chain (Formal); + begin + if Assoc /= Null_Iir then + Set_In_Formal_Flag (Assoc, True); + end if; + end; + return Formal; + when Iir_Kind_String_Literal8 => + -- Operator designator + return String_To_Operator_Symbol (Formal); + when others => + Error_Msg_Parse (+Formal, "incorrect formal name ignored"); + return Null_Iir; + end case; + end Check_Formal_Form; + + -- precond : NEXT_TOKEN + -- postcond: NEXT_TOKEN + -- + -- [ LRM93 4.3.2.2 ] + -- association_list ::= association_element { , association_element } + -- + -- [ LRM93 4.3.2.2 ] + -- association_element ::= [ formal_part => ] actual_part + -- + -- [ LRM93 4.3.2.2 ] + -- actual_part ::= actual_designator + -- | FUNCTION_name ( actual_designator ) + -- | type_mark ( actual_designator ) + -- + -- [ LRM93 4.3.2.2 ] + -- actual_designator ::= expression + -- | SIGNAL_name + -- | VARIABLE_name + -- | FILE_name + -- | OPEN + -- + -- [ LRM93 4.3.2.2 ] + -- formal_part ::= formal_designator + -- | FUNCTION_name ( formal_designator ) + -- | type_mark ( formal_designator ) + -- + -- [ LRM93 4.3.2.2 ] + -- formal_designator ::= GENERIC_name + -- | PORT_name + -- | PARAMETER_name + -- + -- Note: an actual part is parsed as an expression. + function Parse_Association_List return Iir + is + Res, Last: Iir; + El: Iir; + Formal: Iir; + Actual: Iir; + Nbr_Assocs : Natural; + Loc : Location_Type; + Arrow_Loc : Location_Type; + Comma_Loc : Location_Type; + begin + Sub_Chain_Init (Res, Last); + + if Current_Token = Tok_Right_Paren then + Error_Msg_Parse ("empty association list is not allowed"); + return Res; + end if; + + Nbr_Assocs := 1; + loop + -- Parse formal and actual. + Loc := Get_Token_Location; + Arrow_Loc := No_Location; + Formal := Null_Iir; + + if Current_Token /= Tok_Open then + Actual := Parse_Expression; + case Current_Token is + when Tok_To + | Tok_Downto => + -- To/downto can appear in slice name. + + if Actual = Null_Iir then + -- Left expression is missing ie: (downto x). + Scan; + Actual := Parse_Expression; + else + Actual := Parse_Range_Expression (Actual); + end if; + if Nbr_Assocs /= 1 then + Error_Msg_Parse ("multi-dimensional slice is forbidden"); + end if; + + when Tok_Double_Arrow => + -- Check that FORMAL is a name and not an expression. + Formal := Check_Formal_Form (Actual); + Arrow_Loc := Get_Token_Location; + + -- Skip '=>' + Scan; + Loc := Get_Token_Location; + + if Current_Token /= Tok_Open then + Actual := Parse_Expression; + end if; + + when others => + null; + end case; + end if; + + if Current_Token = Tok_Open then + El := Create_Iir (Iir_Kind_Association_Element_Open); + Set_Location (El); + + -- Skip 'open' + Scan; + else + El := Create_Iir (Iir_Kind_Association_Element_By_Expression); + Set_Location (El, Loc); + Set_Actual (El, Actual); + end if; + Set_Formal (El, Formal); + + if Flag_Elocations then + Create_Elocations (El); + Set_Arrow_Location (El, Arrow_Loc); + end if; + + Sub_Chain_Append (Res, Last, El); + exit when Current_Token /= Tok_Comma; + + -- Eat ','. + Comma_Loc := Get_Token_Location; + Scan; + + if Current_Token = Tok_Right_Paren then + Error_Msg_Parse (Comma_Loc, "extra ',' ignored"); + exit; + end if; + + Nbr_Assocs := Nbr_Assocs + 1; + end loop; + + return Res; + end Parse_Association_List; + + -- precond : NEXT_TOKEN + -- postcond: NEXT_TOKEN + -- + -- Parse: '(' association_list ')' + function Parse_Association_List_In_Parenthesis return Iir + is + Res : Iir; + begin + -- Skip '(' + Expect_Scan (Tok_Left_Paren); + + Res := Parse_Association_List; + + -- Skip ')' + Expect_Scan (Tok_Right_Paren); + + return Res; + end Parse_Association_List_In_Parenthesis; + + -- precond : GENERIC + -- postcond: next token + -- + -- [ LRM93 5.2.1.2, LRM08 6.5.7.2 ] + -- generic_map_aspect ::= GENERIC MAP ( GENERIC_association_list ) + function Parse_Generic_Map_Aspect return Iir is + begin + -- Skip 'generic'. + Expect_Scan (Tok_Generic); + + -- Skip 'map'. + Expect_Scan (Tok_Map); + + return Parse_Association_List_In_Parenthesis; + end Parse_Generic_Map_Aspect; + + -- precond : PORT + -- postcond: next token + -- + -- [ LRM93 5.2.1.2 ] + -- port_map_aspect ::= PORT MAP ( PORT_association_list ) + function Parse_Port_Map_Aspect return Iir is + begin + -- Skip 'port'. + Expect_Scan (Tok_Port); + + -- Skip 'map'. + Expect_Scan (Tok_Map); + + return Parse_Association_List_In_Parenthesis; + end Parse_Port_Map_Aspect; + + -- precond : COMPONENT | ENTIY | CONFIGURATION + -- postcond : next_token + -- + -- instantiated_unit ::= + -- [ COMPONENT ] component_name + -- | ENTITY entity_name [ ( architecture_identifier ) ] + -- | CONFIGURATION configuration_name + function Parse_Instantiated_Unit return Iir + is + Res : Iir; + begin + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("component instantiation using keyword 'component', 'entity',", + Cont => True); + Error_Msg_Parse (" or 'configuration' is not allowed in vhdl87"); + end if; + + case Current_Token is + when Tok_Component => + -- Eat 'component'. + Scan; + + return Parse_Name (False); + + when Tok_Entity => + Res := Create_Iir (Iir_Kind_Entity_Aspect_Entity); + Set_Location (Res); + + -- Eat 'entity'. + Scan; + + Set_Entity_Name (Res, Parse_Name (False)); + if Current_Token = Tok_Left_Paren then + -- Skip '('. + Scan; + + if Current_Token = Tok_Identifier then + Set_Architecture (Res, Current_Text); + + -- Skip identifier. + Scan; + else + Expect (Tok_Identifier, "identifier for architecture"); + end if; + + -- Skip ')'. + Expect_Scan (Tok_Right_Paren); + end if; + return Res; + + when Tok_Configuration => + Res := Create_Iir (Iir_Kind_Entity_Aspect_Configuration); + Set_Location (Res); + + -- Skip 'configuration. + Scan; + + Expect (Tok_Identifier); + Set_Configuration_Name (Res, Parse_Name (False)); + return Res; + + when others => + raise Internal_Error; + end case; + end Parse_Instantiated_Unit; + + -- precond : next token + -- postcond: next token + -- + -- component_instantiation_statement ::= + -- INSTANTIATION_label : + -- instantiated_unit [ generic_map_aspect ] [ port_map_aspect ] ; + function Parse_Component_Instantiation (Name: Iir) + return Iir_Component_Instantiation_Statement + is + Res: Iir_Component_Instantiation_Statement; + begin + Res := Create_Iir (Iir_Kind_Component_Instantiation_Statement); + Set_Location (Res); + + Set_Instantiated_Unit (Res, Name); + + if Current_Token = Tok_Generic then + Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect); + end if; + if Current_Token = Tok_Port then + Set_Port_Map_Aspect_Chain (Res, Parse_Port_Map_Aspect); + end if; + Expect_Scan (Tok_Semi_Colon); + return Res; + end Parse_Component_Instantiation; + + -- precond : next token + -- postcond: next token + -- + -- [ LRM93 9.1 ] + -- block_header ::= [ generic_clause [ generic_map_aspect ; ] ] + -- [ port_clause [ port_map_aspect ; ] ] + function Parse_Block_Header return Iir_Block_Header is + Res : Iir_Block_Header; + begin + Res := Create_Iir (Iir_Kind_Block_Header); + Set_Location (Res); + if Current_Token = Tok_Generic then + Parse_Generic_Clause (Res); + if Current_Token = Tok_Generic then + Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect); + Scan_Semi_Colon ("generic map aspect"); + end if; + end if; + if Current_Token = Tok_Port then + Parse_Port_Clause (Res); + if Current_Token = Tok_Port then + Set_Port_Map_Aspect_Chain (Res, Parse_Port_Map_Aspect); + Scan_Semi_Colon ("port map aspect"); + end if; + end if; + return Res; + end Parse_Block_Header; + + -- precond : BLOCK + -- postcond: ';' + -- + -- [ LRM93 9.1 ] + -- block_statement ::= + -- BLOCK_label : + -- BLOCK [ ( GUARD_expression ) ] [ IS ] + -- block_header + -- block_declarative_part + -- BEGIN + -- block_statement_part + -- END BLOCK [ BLOCK_label ] ; + -- + -- [ LRM93 9.1 ] + -- block_declarative_part ::= { block_declarative_item } + -- + -- [ LRM93 9.1 ] + -- block_statement_part ::= { concurrent_statement } + function Parse_Block_Statement (Label: Name_Id; Loc : Location_Type) + return Iir_Block_Statement + is + Res : Iir_Block_Statement; + Guard : Iir_Guard_Signal_Declaration; + Begin_Loc : Location_Type; + begin + if Label = Null_Identifier then + Error_Msg_Parse ("a block statement must have a label"); + end if; + + -- block was just parsed. + Res := Create_Iir (Iir_Kind_Block_Statement); + Set_Location (Res, Loc); + Set_Label (Res, Label); + + -- Eat 'block'. + Scan; + + if Current_Token = Tok_Left_Paren then + Guard := Create_Iir (Iir_Kind_Guard_Signal_Declaration); + Set_Location (Guard); + Set_Guard_Decl (Res, Guard); + + -- Eat '('. + Scan; + + Set_Guard_Expression (Guard, Parse_Expression); + + -- Eat ')'. + Expect_Scan (Tok_Right_Paren, "')' expected after guard expression"); + end if; + + if Current_Token = Tok_Is then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("'is' not allowed here in vhdl87"); + end if; + + -- Eat 'is'. + Scan; + end if; + if Current_Token = Tok_Generic or Current_Token = Tok_Port then + Set_Block_Header (Res, Parse_Block_Header); + end if; + if Current_Token /= Tok_Begin then + Parse_Declarative_Part (Res); + end if; + + Begin_Loc := Get_Token_Location; + + -- Eat 'begin'. + Expect_Scan (Tok_Begin); + + Parse_Concurrent_Statements (Res); + + if Flag_Elocations then + Create_Elocations (Res); + Set_Begin_Location (Res, Begin_Loc); + Set_End_Location (Res, Get_Token_Location); + end if; + + Check_End_Name (Tok_Block, Res); + Expect_Scan (Tok_Semi_Colon); + + return Res; + end Parse_Block_Statement; + + -- Precond : next token + -- Postcond: next token after 'end' + -- + -- [ LRM08 11.8 ] Generate statements + -- generate_statement_body ::= + -- [ block_declarative_part + -- BEGIN ] + -- { concurrent_statement } + -- [ END [ alternative_label ] ; ] + -- + -- This corresponds to the following part of LRM93 9.7: + -- [ { block_declarative_item } + -- BEGIN ] + -- { concurrent_statement } + -- Note there is no END. This part is followed by: + -- END GENERATE [ /generate/_label ] ; + procedure Parse_Generate_Statement_Body (Parent : Iir; + Label : Name_Id; + Bod : out Iir; + End_Loc : out Location_Type) + is + function Is_Early_End return Boolean is + begin + case Current_Token is + when Tok_Elsif + | Tok_Else => + if Get_Kind (Parent) = Iir_Kind_If_Generate_Statement then + return True; + end if; + when Tok_When => + if Get_Kind (Parent) = Iir_Kind_Case_Generate_Statement then + return True; + end if; + when others => + null; + end case; + return False; + end Is_Early_End; + begin + Bod := Create_Iir (Iir_Kind_Generate_Statement_Body); + Set_Location (Bod); + Set_Parent (Bod, Parent); + Set_Alternative_Label (Bod, Label); + Set_Has_Label (Bod, Label /= Null_Identifier); + End_Loc := No_Location; + + if Flag_Elocations then + Create_Elocations (Bod); + end if; + + -- Check for a block declarative item. + case Current_Token is + when + -- subprogram_declaration + -- subprogram_body + Tok_Procedure + | Tok_Function + | Tok_Pure + | Tok_Impure + -- type_declaration + | Tok_Type + -- subtype_declaration + | Tok_Subtype + -- constant_declaration + | Tok_Constant + -- signal_declaration + | Tok_Signal + -- shared_variable_declaration + | Tok_Shared + | Tok_Variable + -- file_declaration + | Tok_File + -- alias_declaration + | Tok_Alias + -- component_declaration + | Tok_Component + -- attribute_declaration + -- attribute_specification + | Tok_Attribute + -- configuration_specification + | Tok_For + -- disconnection_specification + | Tok_Disconnect + -- use_clause + | Tok_Use + -- group_template_declaration + -- group_declaration + | Tok_Group + | Tok_Begin => + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("declarations not allowed in a generate in vhdl87"); + end if; + Parse_Declarative_Part (Bod); + Expect (Tok_Begin); + Set_Has_Begin (Bod, True); + + if Flag_Elocations then + Set_Begin_Location (Bod, Get_Token_Location); + end if; + + -- Skip 'begin' + Scan; + when others => + null; + end case; + + Parse_Concurrent_Statements (Bod); + + -- Return now if no 'end' (and not expected). + if Is_Early_End then + return; + end if; + + -- Skip 'end' + End_Loc := Get_Token_Location; + Expect_Scan (Tok_End); + + if Vhdl_Std >= Vhdl_08 and then Current_Token /= Tok_Generate then + -- This is the 'end' of the generate_statement_body. + Set_Has_End (Bod, True); + if Flag_Elocations then + Set_End_Location (Bod, End_Loc); + end if; + + Check_End_Name (Label, Bod); + Scan_Semi_Colon ("generate statement body"); + + -- Return now if no 'end' (and not expected). + if Is_Early_End then + return; + end if; + + Expect (Tok_End); + End_Loc := Get_Token_Location; + + -- Skip 'end' + Scan; + end if; + end Parse_Generate_Statement_Body; + + -- precond : FOR + -- postcond: ';' + -- + -- [ LRM93 9.7 ] + -- generate_statement ::= + -- GENERATE_label : generation_scheme GENERATE + -- [ { block_declarative_item } + -- BEGIN ] + -- { concurrent_statement } + -- END GENERATE [ GENERATE_label ] ; + -- + -- [ LRM93 9.7 ] + -- generation_scheme ::= + -- FOR GENERATE_parameter_specification + -- | IF condition + -- + -- [ LRM08 11.8 ] + -- for_generate_statement ::= + -- /generate/_label : + -- FOR /generate/_parameter_specification GENERATE + -- generate_statement_body + -- END GENERATE [ /generate/_label ] ; + -- + -- FIXME: block_declarative item. + function Parse_For_Generate_Statement (Label : Name_Id; Loc : Location_Type) + return Iir + is + Res : Iir; + Bod : Iir; + Start_Loc, Generate_Loc, End_Loc : Location_Type; + begin + if Label = Null_Identifier then + Error_Msg_Parse ("a generate statement must have a label"); + end if; + Res := Create_Iir (Iir_Kind_For_Generate_Statement); + Set_Location (Res, Loc); + Set_Label (Res, Label); + Start_Loc := Get_Token_Location; + + -- Skip 'for' + Scan; + + Set_Parameter_Specification (Res, Parse_Parameter_Specification (Res)); + + -- Skip 'generate' + Expect (Tok_Generate); + Generate_Loc := Get_Token_Location; + Scan; + + Parse_Generate_Statement_Body (Res, Null_Identifier, Bod, End_Loc); + Set_Generate_Statement_Body (Res, Bod); + + -- Skip 'generate' + Expect_Scan (Tok_Generate); + Set_End_Has_Reserved_Id (Res, True); + + -- LRM93 9.7 + -- If a label appears at the end of a generate statement, it must repeat + -- the generate label. + Check_End_Name (Res); + Expect_Scan (Tok_Semi_Colon); + + if Flag_Elocations then + Create_Elocations (Res); + Set_Start_Location (Res, Start_Loc); + Set_Generate_Location (Res, Generate_Loc); + Set_End_Location (Res, End_Loc); + end if; + + return Res; + end Parse_For_Generate_Statement; + + -- precond : IF + -- postcond: ';' + -- + -- [ LRM93 9.7 ] + -- generate_statement ::= + -- /generate/_label : generation_scheme GENERATE + -- [ { block_declarative_item } + -- BEGIN ] + -- { concurrent_statement } + -- END GENERATE [ /generate/_label ] ; + -- + -- [ LRM93 9.7 ] + -- generation_scheme ::= + -- FOR GENERATE_parameter_specification + -- | IF condition + -- + -- [ LRM08 11.8 ] + -- if_generate_statement ::= + -- /generate/_label : + -- IF [ /alternative/_label : ] condition GENERATE + -- generate_statement_body + -- { ELSIF [ /alternative/_label : ] condition GENERATE + -- generate_statement_body } + -- [ ELSE [ /alternative/_label : ] GENERATE + -- generate_statement_body ] + -- END GENERATE [ /generate/_label ] ; + function Parse_If_Generate_Statement (Label : Name_Id; Loc : Location_Type) + return Iir_Generate_Statement + is + Res : Iir_Generate_Statement; + Alt_Label : Name_Id; + Alt_Loc : Location_Type; + Cond : Iir; + Clause : Iir; + Bod : Iir; + Last : Iir; + Start_Loc, Generate_Loc, End_Loc : Location_Type; + begin + if Label = Null_Identifier then + Error_Msg_Parse ("a generate statement must have a label"); + end if; + Res := Create_Iir (Iir_Kind_If_Generate_Statement); + Set_Location (Res, Loc); + Set_Label (Res, Label); + Start_Loc := Get_Token_Location; + + -- Skip 'if'. + Scan; + + Clause := Res; + Last := Null_Iir; + loop + Cond := Parse_Expression; + + Alt_Label := Null_Identifier; + if Current_Token = Tok_Colon then + if Get_Kind (Cond) = Iir_Kind_Simple_Name then + if Vhdl_Std < Vhdl_08 then + Error_Msg_Parse + ("alternative label not allowed before vhdl08"); + end if; + + -- In fact the parsed condition was an alternate label. + Alt_Label := Get_Identifier (Cond); + Alt_Loc := Get_Location (Cond); + Free_Iir (Cond); + else + Error_Msg_Parse ("alternative label must be an identifier"); + Free_Iir (Cond); + end if; + + -- Skip ':' + Scan; + + Cond := Parse_Expression; + end if; + + Set_Condition (Clause, Cond); + + -- Skip 'generate' + Generate_Loc := Get_Token_Location; + Expect_Scan (Tok_Generate); + + Parse_Generate_Statement_Body (Res, Alt_Label, Bod, End_Loc); + + if Alt_Label /= Null_Identifier then + -- Set location on the label, for xrefs. + Set_Location (Bod, Alt_Loc); + end if; + + Set_Generate_Statement_Body (Clause, Bod); + + -- Append clause to the generate statement. + if Last /= Null_Iir then + Set_Generate_Else_Clause (Last, Clause); + end if; + Last := Clause; + + if Flag_Elocations then + Create_Elocations (Clause); + Set_Start_Location (Clause, Start_Loc); + Set_Generate_Location (Clause, Generate_Loc); + Set_End_Location (Clause, End_Loc); + end if; + + exit when Current_Token /= Tok_Elsif; + + -- Create new alternative. + Clause := Create_Iir (Iir_Kind_If_Generate_Statement); + Set_Location (Clause, Loc); + Start_Loc := Get_Token_Location; + + -- Skip 'elsif' + Scan; + end loop; + + if Current_Token = Tok_Else then + if Vhdl_Std < Vhdl_08 then + Error_Msg_Parse ("else generate not allowed before vhdl08"); + end if; + + Clause := Create_Iir (Iir_Kind_If_Generate_Else_Clause); + Start_Loc := Get_Token_Location; + Set_Location (Clause, Start_Loc); + + -- Skip 'else' + Scan; + + if Current_Token = Tok_Identifier then + Alt_Label := Current_Identifier; + Alt_Loc := Get_Token_Location; + + -- Skip identifier + Scan; + + -- Skip ':' + Expect_Scan (Tok_Colon); + else + Alt_Label := Null_Identifier; + end if; + + -- Skip 'generate' + Generate_Loc := Get_Token_Location; + Expect_Scan (Tok_Generate); + + Parse_Generate_Statement_Body (Res, Alt_Label, Bod, End_Loc); + if Alt_Label /= Null_Identifier then + -- Set location on the label, for xrefs. + Set_Location (Bod, Alt_Loc); + end if; + + Set_Generate_Statement_Body (Clause, Bod); + + Set_Generate_Else_Clause (Last, Clause); + + if Flag_Elocations then + Create_Elocations (Clause); + Set_Start_Location (Clause, Start_Loc); + Set_Generate_Location (Clause, Generate_Loc); + Set_End_Location (Clause, End_Loc); + end if; + end if; + + -- Skip 'generate' + Expect_Scan (Tok_Generate); + Set_End_Has_Reserved_Id (Res, True); + + -- LRM93 9.7 + -- If a label appears at the end of a generate statement, it must repeat + -- the generate label. + Check_End_Name (Res); + Expect_Scan (Tok_Semi_Colon); + return Res; + end Parse_If_Generate_Statement; + + -- precond : WHEN + -- postcond: ? + -- + -- [ LRM08 11.8 ] + -- case_generate_alternative ::= + -- WHEN [ /alternative/_label : ] choices => + -- generate_statement_body + procedure Parse_Case_Generate_Alternative (Parent : Iir; Assoc : out Iir) + is + Loc : Location_Type; + Alt_Label : Name_Id; + Bod : Iir; + Expr : Iir; + End_Loc : Location_Type; + begin + Loc := Get_Token_Location; + + -- Eat 'when' + Expect (Tok_When); + Scan; + + Alt_Label := Null_Identifier; + if Current_Token = Tok_Double_Arrow then + Error_Msg_Parse ("missing expression in alternative"); + Assoc := Create_Iir (Iir_Kind_Choice_By_Expression); + Set_Location (Assoc); + elsif Current_Token = Tok_Others then + -- 'others' is not an expression! + Parse_Choices (Null_Iir, Loc, Assoc); + else + Expr := Parse_Expression; + + if Current_Token = Tok_Colon then + if Get_Kind (Expr) = Iir_Kind_Simple_Name then + -- In fact the parsed condition was an alternate label. + Alt_Label := Get_Identifier (Expr); + Loc := Get_Location (Expr); + Free_Iir (Expr); + else + Error_Msg_Parse ("alternative label must be an identifier"); + Free_Iir (Expr); + end if; + + Expr := Null_Iir; + + -- Skip ':' + Scan; + end if; + + Parse_Choices (Expr, Loc, Assoc); + end if; + + -- Set location of label (if any, for xref) or location of 'when'. + Set_Location (Assoc, Loc); + + -- Eat '=>' + Expect_Scan (Tok_Double_Arrow); + + Parse_Generate_Statement_Body (Parent, Alt_Label, Bod, End_Loc); + Set_Associated_Block (Assoc, Bod); + if Alt_Label /= Null_Identifier then + -- Set location on the label, for xrefs. + Set_Location (Bod, Loc); + end if; + end Parse_Case_Generate_Alternative; + + -- precond : CASE + -- postcond: ';' + -- + -- [ LRM08 11.8 ] + -- case_generate_statement ::= + -- /generate/_label : + -- CASE expression GENERATE + -- case_generate_alternative + -- { case_generate_alternative } + -- END GENERATE [ /generate/_label ] ; + function Parse_Case_Generate_Statement + (Label : Name_Id; Loc : Location_Type) return Iir + is + Res : Iir; + Alt : Iir; + Last_Alt : Iir; + begin + if Label = Null_Identifier then + Error_Msg_Parse ("a generate statement must have a label"); + end if; + Res := Create_Iir (Iir_Kind_Case_Generate_Statement); + Set_Location (Res, Loc); + Set_Label (Res, Label); + + -- Skip 'case'. + Scan; + + Set_Expression (Res, Parse_Expression); + + -- Skip 'generate' + Expect_Scan (Tok_Generate); + + if Current_Token = Tok_End then + Error_Msg_Parse ("no generate alternative"); + end if; + + Last_Alt := Null_Iir; + while Current_Token = Tok_When loop + Parse_Case_Generate_Alternative (Res, Alt); + if Last_Alt = Null_Iir then + Set_Case_Statement_Alternative_Chain (Res, Alt); + else + Set_Chain (Last_Alt, Alt); + end if; + + -- Skip until last choice of the choices list. + loop + Last_Alt := Alt; + Alt := Get_Chain (Alt); + exit when Alt = Null_Iir; + end loop; + end loop; + + -- Skip 'generate' + Expect_Scan (Tok_Generate); + Set_End_Has_Reserved_Id (Res, True); + + -- LRM93 9.7 + -- If a label appears at the end of a generate statement, it must repeat + -- the generate label. + Check_End_Name (Res); + Expect_Scan (Tok_Semi_Colon); + + return Res; + end Parse_Case_Generate_Statement; + + -- precond : first token + -- postcond: next token + -- + -- [ LRM93 9.3 ] + -- concurrent_procedure_call_statement ::= + -- [ label : ] [ POSTPONED ] procedure_call ; + -- + -- [ LRM93 9.5 ] + -- concurrent_signal_assignment_statement ::= + -- [ label : ] [ POSTPONED ] conditional_signal_assignment + -- | [ label : ] [ POSTPONED ] selected_signal_assignment + function Parse_Concurrent_Assignment (Target : Iir) return Iir + is + Res : Iir; + begin + case Current_Token is + when Tok_Less_Equal + | Tok_Assign => + -- This is a conditional signal assignment. + -- Error for ':=' is handled by the subprogram. + return Parse_Concurrent_Conditional_Signal_Assignment (Target); + when Tok_Semi_Colon => + -- a procedure call or a component instantiation. + -- Parse it as a procedure call, may be revert to a + -- component instantiation during sem. + Res := Parenthesis_Name_To_Procedure_Call + (Target, Iir_Kind_Concurrent_Procedure_Call_Statement); + + -- Skip ';'. + Scan; + + return Res; + when Tok_Generic | Tok_Port => + -- or a component instantiation. + return Parse_Component_Instantiation (Target); + when others => + -- Catch PSL clock declaration. Within comments, this is the + -- right place (and handled as a concurrent statement). After + -- vhdl08, it is a declaration. + if Get_Kind (Target) = Iir_Kind_Simple_Name + and then Get_Identifier (Target) = Name_Default + and then Current_Token = Tok_Identifier + and then Current_Identifier = Name_Clock + then + Error_Msg_Parse (+Target, "PSL default clock is a declaration"); + + Current_Token := Tok_Psl_Clock; + Res := Parse_Psl_Default_Clock_Cont (Get_Location (Target)); + + return Res; + end if; + + -- or a simple simultaneous statement + if AMS_Vhdl then + Res := Create_Iir (Iir_Kind_Simple_Simultaneous_Statement); + Set_Simultaneous_Left + (Res, Parse_Binary_Expression (Target, Prio_Simple)); + if Current_Token /= Tok_Equal_Equal then + Error_Msg_Parse ("'==' expected after expression"); + else + Set_Location (Res); + Scan; + end if; + Set_Simultaneous_Right (Res, Parse_Expression (Prio_Simple)); + Set_Tolerance (Res, Parse_Tolerance_Aspect_Opt); + Expect_Scan (Tok_Semi_Colon); + return Res; + else + return Parse_Concurrent_Conditional_Signal_Assignment + (Parse_Binary_Expression (Target, Prio_Simple)); + end if; + end case; + end Parse_Concurrent_Assignment; + + -- Parse end of PSL assert/cover statement. + procedure Parse_Psl_Assert_Report_Severity (Stmt : Iir) is + begin + -- No more PSL tokens after the property. + Vhdl.Scanner.Flag_Psl := False; + + if Current_Token = Tok_Report then + -- Skip 'report' + Scan; + + Set_Report_Expression (Stmt, Parse_Expression); + end if; + + if Current_Token = Tok_Severity then + -- Skip 'severity' + Scan; + + Set_Severity_Expression (Stmt, Parse_Expression); + end if; + + Vhdl.Scanner.Flag_Scan_In_Comment := False; + + Expect_Scan (Tok_Semi_Colon); + end Parse_Psl_Assert_Report_Severity; + + function Parse_Psl_Assert_Statement return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Psl_Assert_Statement); + + -- Accept PSL tokens + if Flags.Vhdl_Std >= Vhdl_08 then + Vhdl.Scanner.Flag_Psl := True; + end if; + + -- Skip 'assert' + Scan; + + Set_Psl_Property (Res, Parse_Psl.Parse_Psl_Property); + + Parse_Psl_Assert_Report_Severity (Res); + + return Res; + end Parse_Psl_Assert_Statement; + + function Parse_Psl_Cover_Statement return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Psl_Cover_Statement); + + -- Skip 'cover' + Scan; + + Set_Psl_Sequence (Res, Parse_Psl.Parse_Psl_Sequence (True)); + + Parse_Psl_Assert_Report_Severity (Res); + + return Res; + end Parse_Psl_Cover_Statement; + + -- precond : first token + -- postcond: next token (end/else/when...) + -- + -- [ LRM93 9 ] + -- concurrent_statement ::= block_statement + -- | process_statement + -- | concurrent_procedure_call_statement + -- | concurrent_assertion_statement + -- | concurrent_signal_assignment_statement + -- | component_instantiation_statement + -- | generate_statement + -- + procedure Parse_Concurrent_Statements (Parent : Iir) + is + Last_Stmt : Iir; + Stmt: Iir; + Label: Name_Id; + Id: Iir; + Postponed : Boolean; + Loc : Location_Type; + Target : Iir; + + procedure Postponed_Not_Allowed is + begin + if Postponed then + Error_Msg_Parse ("'postponed' not allowed here"); + Postponed := False; + end if; + end Postponed_Not_Allowed; + + procedure Label_Not_Allowed is + begin + if Label /= Null_Identifier then + Error_Msg_Parse ("'postponed' not allowed here"); + Label := Null_Identifier; + end if; + end Label_Not_Allowed; + begin + -- begin was just parsed. + Last_Stmt := Null_Iir; + loop + Stmt := Null_Iir; + Label := Null_Identifier; + Postponed := False; + Loc := Get_Token_Location; + + -- Try to find a label. + if Current_Token = Tok_Identifier then + Label := Current_Identifier; + + -- Skip identifier + Scan; + + if Current_Token = Tok_Colon then + -- The identifier is really a label. + + -- Skip ':' + Scan; + else + -- This is not a label. Assume a concurrent assignment. + Target := Create_Iir (Iir_Kind_Simple_Name); + Set_Location (Target, Loc); + Set_Identifier (Target, Label); + Label := Null_Identifier; + Target := Parse_Name_Suffix (Target); + + Stmt := Parse_Concurrent_Assignment (Target); + goto Has_Stmt; + end if; + end if; + + if Current_Token = Tok_Postponed then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("'postponed' is not allowed in vhdl 87"); + else + Postponed := True; + end if; + + -- Skip 'postponed' + Scan; + end if; + + case Current_Token is + when Tok_End | Tok_Else | Tok_Elsif | Tok_When => + -- End of list. 'else', 'elseif' and 'when' can be used to + -- separate statements in a generate statement. + Postponed_Not_Allowed; + if Label /= Null_Identifier then + Error_Msg_Parse ("label is not allowed here"); + end if; + return; + when Tok_Identifier => + Target := Parse_Name (Allow_Indexes => True); + Stmt := Parse_Concurrent_Assignment (Target); + if Get_Kind (Stmt) = Iir_Kind_Component_Instantiation_Statement + and then Postponed + then + Error_Msg_Parse ("'postponed' not allowed for " & + "an instantiation statement"); + Postponed := False; + end if; + when Tok_Left_Paren => + Id := Parse_Aggregate; + if Current_Token = Tok_Less_Equal then + -- This is a conditional signal assignment. + Stmt := Parse_Concurrent_Conditional_Signal_Assignment (Id); + else + Error_Msg_Parse ("'<=' expected after aggregate"); + Skip_Until_Semi_Colon; + end if; + when Tok_Process => + Stmt := Parse_Process_Statement (Label, Loc, Postponed); + when Tok_Assert => + if Vhdl_Std >= Vhdl_08 + or else (Flag_Psl_Comment and then Flag_Scan_In_Comment) + then + Stmt := Parse_Psl_Assert_Statement; + else + Stmt := Create_Iir (Iir_Kind_Concurrent_Assertion_Statement); + Parse_Assertion (Stmt); + Expect_Scan (Tok_Semi_Colon); + end if; + when Tok_With => + Stmt := Parse_Selected_Signal_Assignment; + when Tok_Block => + Postponed_Not_Allowed; + Stmt := Parse_Block_Statement (Label, Loc); + when Tok_For => + Postponed_Not_Allowed; + Stmt := Parse_For_Generate_Statement (Label, Loc); + when Tok_If => + Postponed_Not_Allowed; + Stmt := Parse_If_Generate_Statement (Label, Loc); + when Tok_Case => + Postponed_Not_Allowed; + Stmt := Parse_Case_Generate_Statement (Label, Loc); + when Tok_Eof => + Error_Msg_Parse ("unexpected end of file, 'END;' expected"); + return; + when Tok_Component + | Tok_Entity + | Tok_Configuration => + Postponed_Not_Allowed; + declare + Unit : Iir; + Has_Component : constant Boolean := + Current_Token = Tok_Component; + begin + Unit := Parse_Instantiated_Unit; + Stmt := Parse_Component_Instantiation (Unit); + Set_Has_Component (Stmt, Has_Component); + end; + when Tok_Psl_Default => + Postponed_Not_Allowed; + Label_Not_Allowed; + Stmt := Parse_Psl_Default_Clock; + when Tok_Psl_Property + | Tok_Psl_Sequence + | Tok_Psl_Endpoint => + Postponed_Not_Allowed; + Label_Not_Allowed; + Stmt := Parse_Psl_Declaration; + when Tok_Psl_Cover => + Postponed_Not_Allowed; + Stmt := Parse_Psl_Cover_Statement; + when Tok_Wait + | Tok_Loop + | Tok_While => + Error_Msg_Parse + ("sequential statement only allowed in processes"); + Stmt := Parse_Sequential_Statements (Parent); + Stmt := Null_Iir; + when others => + -- FIXME: improve message: + -- instead of 'unexpected token 'signal' in conc stmt list' + -- report: 'signal declarations are not allowed in conc stmt' + Unexpected ("concurrent statement list"); + Resync_To_End_Of_Statement; + if Current_Token = Tok_Semi_Colon then + Scan; + end if; + end case; + + << Has_Stmt >> null; + + -- Stmt can be null in case of error. + if Stmt /= Null_Iir then + Set_Location (Stmt, Loc); + if Label /= Null_Identifier then + Set_Label (Stmt, Label); + end if; + Set_Parent (Stmt, Parent); + if Postponed then + Set_Postponed_Flag (Stmt, True); + end if; + -- Append it to the chain. + if Last_Stmt = Null_Iir then + Set_Concurrent_Statement_Chain (Parent, Stmt); + else + Set_Chain (Last_Stmt, Stmt); + end if; + Last_Stmt := Stmt; + end if; + end loop; + end Parse_Concurrent_Statements; + + -- precond : LIBRARY + -- postcond: ; + -- + -- [ LRM93 11.2 ] + -- library_clause ::= LIBRARY logical_name_list + function Parse_Library_Clause return Iir + is + First, Last : Iir; + Library: Iir_Library_Clause; + Start_Loc : Location_Type; + begin + Sub_Chain_Init (First, Last); + Expect (Tok_Library); + loop + Library := Create_Iir (Iir_Kind_Library_Clause); + Start_Loc := Get_Token_Location; + Sub_Chain_Append (First, Last, Library); + + -- Skip 'library' or ','. + Scan; + + Scan_Identifier (Library); + + if Flag_Elocations then + Create_Elocations (Library); + Set_Start_Location (Library, Start_Loc); + end if; + + exit when Current_Token /= Tok_Comma; + + Set_Has_Identifier_List (Library, True); + end loop; + + -- Skip ';'. + Scan_Semi_Colon ("library clause"); + + return First; + end Parse_Library_Clause; + + -- precond : USE + -- postcond: next token (after ';'). + -- + -- [ LRM93 10.4 ] + -- use_clause ::= USE selected_name { , selected_name } + -- + -- FIXME: should be a list. + function Parse_Use_Clause return Iir_Use_Clause + is + Use_Clause: Iir_Use_Clause; + Loc : Location_Type; + First, Last : Iir; + begin + First := Null_Iir; + Last := Null_Iir; + + Loc := Get_Token_Location; + + -- Skip 'use'. + Scan; + + loop + Use_Clause := Create_Iir (Iir_Kind_Use_Clause); + Set_Location (Use_Clause, Loc); + Expect (Tok_Identifier); + Set_Selected_Name (Use_Clause, Parse_Name); + + -- Chain use clauses. + if First = Null_Iir then + First := Use_Clause; + else + Set_Use_Clause_Chain (Last, Use_Clause); + end if; + Last := Use_Clause; + + exit when Current_Token /= Tok_Comma; + Loc := Get_Token_Location; + + -- Skip ','. + Scan; + end loop; + + -- Skip ';'. + Scan_Semi_Colon ("use clause"); + + return First; + end Parse_Use_Clause; + + -- precond : ARCHITECTURE + -- postcond: ';'. + -- + -- [ LRM93 1.2 ] + -- architecture_body ::= + -- ARCHITECTURE identifier OF ENTITY_name IS + -- architecture_declarative_part + -- BEGIN + -- architecture_statement_part + -- END [ ARCHITECTURE ] [ ARCHITECTURE_simple_name ] ; + procedure Parse_Architecture_Body (Unit : Iir_Design_Unit) + is + Res : Iir_Architecture_Body; + Start_Loc : Location_Type; + Begin_Loc : Location_Type; + End_Loc : Location_Type; + begin + Expect (Tok_Architecture); + Res := Create_Iir (Iir_Kind_Architecture_Body); + Start_Loc := Get_Token_Location; + + -- Skip 'architecture'. + Scan; + + -- Identifier. + Scan_Identifier (Res); + + -- Skip 'of'. + Expect_Scan (Tok_Of); + + Set_Entity_Name (Res, Parse_Name (False)); + + -- Skip 'is'. + Expect_Scan (Tok_Is); + + Parse_Declarative_Part (Res); + + -- Skip 'begin'. + Begin_Loc := Get_Token_Location; + Expect_Scan (Tok_Begin); + + Parse_Concurrent_Statements (Res); + -- end was scanned. + End_Loc := Get_Token_Location; + + -- Skip 'end'. + Expect_Scan (Tok_End); + + if Current_Token = Tok_Architecture then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("'architecture' keyword not allowed here by vhdl 87"); + end if; + Set_End_Has_Reserved_Id (Res, True); + + -- Skip 'architecture'. + Scan; + end if; + Check_End_Name (Res); + Scan_Semi_Colon_Unit ("architecture"); + + Set_Library_Unit (Unit, Res); + + if Flag_Elocations then + Create_Elocations (Res); + Set_Start_Location (Res, Start_Loc); + Set_Begin_Location (Res, Begin_Loc); + Set_End_Location (Res, End_Loc); + end if; + end Parse_Architecture_Body; + + -- precond : next token + -- postcond: a token + -- + -- [ LRM93 5.2 ] + -- instantiation_list ::= INSTANTIATION_label { , INSTANTIATION_label } + -- | OTHERS + -- | ALL + -- + -- FIXME: merge with parse_signal_list ? + function Parse_Instantiation_List return Iir_Flist + is + Res : Iir_List; + begin + case Current_Token is + when Tok_All => + -- Skip 'all'. + Scan; + + return Iir_Flist_All; + + when Tok_Others => + -- Skip 'others'. + Scan; + + return Iir_Flist_Others; + + when Tok_Identifier => + Res := Create_Iir_List; + loop + Append_Element (Res, Current_Text); + -- Skip identifier. + Scan; + + exit when Current_Token /= Tok_Comma; + + -- Skip ','. + Scan; + + if Current_Token /= Tok_Identifier then + Expect (Tok_Identifier); + exit; + end if; + end loop; + return List_To_Flist (Res); + + when others => + Error_Msg_Parse ("instantiation list expected"); + return Null_Iir_Flist; + end case; + end Parse_Instantiation_List; + + -- precond : next token + -- postcond: next token + -- + -- [ LRM93 5.2 ] + -- component_specification ::= instantiation_list : COMPONENT_name + procedure Parse_Component_Specification (Res : Iir) + is + List : Iir_Flist; + begin + List := Parse_Instantiation_List; + Set_Instantiation_List (Res, List); + + -- Skip ':'. + Expect_Scan (Tok_Colon); + + Expect (Tok_Identifier); + Set_Component_Name (Res, Parse_Name); + end Parse_Component_Specification; + + -- precond : next token + -- postcond: next token + -- + -- [ LRM93 5.2.1.1 ] + -- entity_aspect ::= ENTITY ENTITY_name [ ( ARCHITECTURE_identifier ) ] + function Parse_Entity_Aspect_Entity return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Entity_Aspect_Entity); + Set_Location (Res); + + if Current_Token = Tok_Entity then + -- Eat 'entity' (but only if present). + Scan; + end if; + + Expect (Tok_Identifier); + Set_Entity_Name (Res, Parse_Name (False)); + + -- Optional architecture + if Current_Token = Tok_Left_Paren then + -- Skip '('. + Scan; + + if Current_Token = Tok_Identifier then + Set_Architecture (Res, Current_Text); + + -- Skip identifier. + Scan; + else + Expect (Tok_Identifier); + end if; + + Expect_Scan (Tok_Right_Paren); + end if; + + return Res; + end Parse_Entity_Aspect_Entity; + + -- precond : next token + -- postcond: next token + -- + -- [ LRM93 5.2.1.1 ] + -- entity_aspect ::= ENTITY ENTITY_name [ ( ARCHITECTURE_identifier ) ] + -- | CONFIGURATION CONFIGURATION_name + -- | OPEN + function Parse_Entity_Aspect return Iir + is + Res : Iir; + begin + case Current_Token is + when Tok_Entity => + Res := Parse_Entity_Aspect_Entity; + when Tok_Configuration => + Res := Create_Iir (Iir_Kind_Entity_Aspect_Configuration); + Set_Location (Res); + + -- Skip 'configuration'. + Scan; + + Expect (Tok_Identifier); + Set_Configuration_Name (Res, Parse_Name (False)); + when Tok_Open => + Res := Create_Iir (Iir_Kind_Entity_Aspect_Open); + Set_Location (Res); + Scan; + when others => + Error_Msg_Parse ("'entity', 'configuration' or 'open' expected"); + -- Assume 'entity' is missing (common case). + Res := Parse_Entity_Aspect_Entity; + end case; + return Res; + end Parse_Entity_Aspect; + + -- precond : next token + -- postcond: next token + -- + -- [ LRM93 5.2.1 ] + -- binding_indication ::= + -- [ USE entity_aspect ] + -- [ generic_map_aspect ] + -- [ port_map_aspect ] + function Parse_Binding_Indication return Iir_Binding_Indication + is + Res : Iir_Binding_Indication; + begin + case Current_Token is + when Tok_Use + | Tok_Generic + | Tok_Port => + null; + when others => + return Null_Iir; + end case; + Res := Create_Iir (Iir_Kind_Binding_Indication); + Set_Location (Res); + if Current_Token = Tok_Use then + Scan; + Set_Entity_Aspect (Res, Parse_Entity_Aspect); + end if; + if Current_Token = Tok_Generic then + Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect); + end if; + if Current_Token = Tok_Port then + Set_Port_Map_Aspect_Chain (Res, Parse_Port_Map_Aspect); + end if; + return Res; + end Parse_Binding_Indication; + + -- precond : ':' after instantiation_list. + -- postcond: next token. + -- + -- [ LRM93 1.3.2 ] + -- component_configuration ::= + -- FOR component_specification + -- [ binding_indication ; ] + -- [ block_configuration ] + -- END FOR ; + function Parse_Component_Configuration (Loc : Location_Type; + Inst_List : Iir_Flist) + return Iir_Component_Configuration + is + Res : Iir_Component_Configuration; + begin + Res := Create_Iir (Iir_Kind_Component_Configuration); + Set_Location (Res, Loc); + + -- Skip ':'. + pragma Assert (Current_Token = Tok_Colon); + Scan; + + -- Component specification. + Set_Instantiation_List (Res, Inst_List); + + Expect (Tok_Identifier); + Set_Component_Name (Res, Parse_Name); + + case Current_Token is + when Tok_Use + | Tok_Generic + | Tok_Port => + Set_Binding_Indication (Res, Parse_Binding_Indication); + Scan_Semi_Colon ("binding indication"); + when others => + null; + end case; + if Current_Token = Tok_For then + Set_Block_Configuration (Res, Parse_Block_Configuration); + end if; + Expect_Scan (Tok_End); + Expect_Scan (Tok_For); + Expect_Scan (Tok_Semi_Colon); + return Res; + end Parse_Component_Configuration; + + -- precond : FOR + -- postcond: next token. + -- + -- [ LRM93 1.3.1 ] + -- block_configuration ::= + -- FOR block_specification + -- { use_clause } + -- { configuration_item } + -- END FOR ; + -- + -- [ LRM93 1.3.1 ] + -- block_specification ::= + -- ARCHITECTURE_name + -- | BLOCK_STATEMENT_label + -- | GENERATE_STATEMENT_label [ ( index_specification ) ] + function Parse_Block_Configuration_Suffix (Loc : Location_Type; + Block_Spec : Iir) + return Iir + is + Res : Iir_Block_Configuration; + begin + Res := Create_Iir (Iir_Kind_Block_Configuration); + Set_Location (Res, Loc); + + Set_Block_Specification (Res, Block_Spec); + + -- Parse use clauses. + if Current_Token = Tok_Use then + declare + Last : Iir; + use Declaration_Chain_Handling; + begin + Build_Init (Last); + + while Current_Token = Tok_Use loop + Append_Subchain (Last, Res, Parse_Use_Clause); + end loop; + end; + end if; + + -- Parse configuration item list + declare + use Iir_Chains.Configuration_Item_Chain_Handling; + Last : Iir; + begin + Build_Init (Last); + while Current_Token = Tok_For loop + Append (Last, Res, Parse_Configuration_Item); + end loop; + end; + Expect_Scan (Tok_End); + Expect_Scan (Tok_For); + Expect_Scan (Tok_Semi_Colon); + return Res; + end Parse_Block_Configuration_Suffix; + + function Parse_Block_Configuration return Iir_Block_Configuration + is + Loc : Location_Type; + begin + Loc := Get_Token_Location; + + -- Skip 'for'. + Expect_Scan (Tok_For); + + return Parse_Block_Configuration_Suffix (Loc, Parse_Name); + end Parse_Block_Configuration; + + -- precond : FOR + -- postcond: next token. + -- + -- [ LRM93 1.3.1 ] + -- configuration_item ::= block_configuration + -- | component_configuration + function Parse_Configuration_Item return Iir + is + Loc : Location_Type; + List : Iir_List; + Flist : Iir_Flist; + El : Iir; + begin + Loc := Get_Token_Location; + Expect_Scan (Tok_For); + + -- ALL and OTHERS are tokens from an instantiation list. + -- Thus, the rule is a component_configuration. + case Current_Token is + when Tok_All => + -- Skip 'all'. + Scan; + + return Parse_Component_Configuration (Loc, Iir_Flist_All); + + when Tok_Others => + -- Skip 'others'. + Scan; + + return Parse_Component_Configuration (Loc, Iir_Flist_Others); + + when Tok_Identifier => + El := Current_Text; + + -- Skip identifier. + Scan; + + case Current_Token is + when Tok_Colon => + -- The identifier was a label from an instantiation list. + Flist := Create_Iir_Flist (1); + Set_Nth_Element (Flist, 0, El); + return Parse_Component_Configuration (Loc, Flist); + when Tok_Comma => + -- The identifier was a label from an instantiation list. + List := Create_Iir_List; + Append_Element (List, El); + while Current_Token = Tok_Comma loop + -- Skip ','. + Scan; + + if Current_Token = Tok_Identifier then + Append_Element (List, Current_Text); + + -- Skip identifier. + Scan; + else + Expect (Tok_Identifier); + exit; + end if; + end loop; + Flist := List_To_Flist (List); + return Parse_Component_Configuration (Loc, Flist); + when Tok_Left_Paren => + El := Parse_Name_Suffix (El); + return Parse_Block_Configuration_Suffix (Loc, El); + when Tok_Use | Tok_For | Tok_End => + -- Possibilities for a block_configuration. + -- FIXME: should use 'when others' ? + return Parse_Block_Configuration_Suffix (Loc, El); + when others => + Error_Msg_Parse + ("block_configuration or component_configuration " + & "expected"); + return Null_Iir; + end case; + when others => + Error_Msg_Parse ("configuration item expected"); + return Null_Iir; + end case; + end Parse_Configuration_Item; + + -- precond : next token + -- postcond: next token + -- + -- [ LRM93 1.3] + -- configuration_declarative_part ::= { configuration_declarative_item } + -- + -- [ LRM93 1.3] + -- configuration_declarative_item ::= use_clause + -- | attribute_specification + -- | group_declaration + -- FIXME: attribute_specification, group_declaration + procedure Parse_Configuration_Declarative_Part (Parent : Iir) + is + use Declaration_Chain_Handling; + Last : Iir; + El : Iir; + begin + Build_Init (Last); + loop + case Current_Token is + when Tok_Invalid => + raise Internal_Error; + when Tok_Use => + Append_Subchain (Last, Parent, Parse_Use_Clause); + when Tok_Attribute => + El := Parse_Attribute; + if El /= Null_Iir then + if Get_Kind (El) /= Iir_Kind_Attribute_Specification then + Error_Msg_Parse + ("attribute declaration not allowed here"); + end if; + Append (Last, Parent, El); + end if; + when Tok_Group => + El := Parse_Group; + if El /= Null_Iir then + if Get_Kind (El) /= Iir_Kind_Group_Declaration then + Error_Msg_Parse + ("group template declaration not allowed here"); + end if; + Append (Last, Parent, El); + end if; + when others => + exit; + end case; + end loop; + end Parse_Configuration_Declarative_Part; + + -- precond : CONFIGURATION + -- postcond: next token. + -- + -- [ LRM93 1.3 ] + -- configuration_declaration ::= + -- CONFIGURATION identifier OF ENTITY_name IS + -- configuration_declarative_part + -- block_configuration + -- END [ CONFIGURATION ] [ CONFIGURATION_simple_name ] ; + -- + -- [ LRM93 1.3 ] + -- configuration_declarative_part ::= { configuration_declarative_item } + procedure Parse_Configuration_Declaration (Unit : Iir_Design_Unit) + is + Res : Iir_Configuration_Declaration; + Start_Loc : Location_Type; + End_Loc : Location_Type; + begin + pragma Assert (Current_Token = Tok_Configuration); + Res := Create_Iir (Iir_Kind_Configuration_Declaration); + Start_Loc := Get_Token_Location; + + -- Skip 'configuration'. + pragma Assert (Current_Token = Tok_Configuration); + Scan; + + -- Get identifier. + Scan_Identifier (Res); + + -- Skip 'of'. + Expect_Scan (Tok_Of); + + Set_Entity_Name (Res, Parse_Name (False)); + + -- Skip 'is'. + Expect_Scan (Tok_Is); + + Parse_Configuration_Declarative_Part (Res); + + Set_Block_Configuration (Res, Parse_Block_Configuration); + + End_Loc := Get_Token_Location; + -- Skip 'end'. + Expect_Scan (Tok_End); + + if Current_Token = Tok_Configuration then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse + ("'configuration' keyword not allowed here by vhdl 87"); + end if; + Set_End_Has_Reserved_Id (Res, True); + + -- Skip 'configuration'. + Scan; + end if; + + -- LRM93 1.3 + -- If a simple name appears at the end of a configuration declaration, + -- it must repeat the identifier of the configuration declaration. + Check_End_Name (Res); + Scan_Semi_Colon_Unit ("configuration"); + + Set_Library_Unit (Unit, Res); + + if Flag_Elocations then + Create_Elocations (Res); + Set_Start_Location (Res, Start_Loc); + Set_End_Location (Res, End_Loc); + end if; + end Parse_Configuration_Declaration; + + -- precond : generic + -- postcond: next token + -- + -- [ LRM08 4.7 ] + -- package_header ::= + -- [ generic_clause -- LRM08 6.5.6.2 + -- [ generic_map aspect ; ] ] + function Parse_Package_Header return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Package_Header); + Set_Location (Res); + Parse_Generic_Clause (Res); + + if Current_Token = Tok_Generic then + Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect); + Scan_Semi_Colon ("generic map aspect"); + end if; + return Res; + end Parse_Package_Header; + + -- precond : token (after 'IS') + -- postcond: next token. + -- + -- [ LRM93 2.5, LRM08 4.7 ] + -- package_declaration ::= + -- PACKAGE identifier IS + -- package_header -- LRM08 + -- package_declarative_part + -- END [ PACKAGE ] [ PACKAGE_simple_name ] ; + function Parse_Package_Declaration + (Parent : Iir; Id : Name_Id; Loc : Location_Type) return Iir + is + Res: Iir_Package_Declaration; + End_Loc : Location_Type; + begin + Res := Create_Iir (Iir_Kind_Package_Declaration); + Set_Location (Res, Loc); + Set_Identifier (Res, Id); + Set_Parent (Res, Parent); + + if Current_Token = Tok_Generic then + if Vhdl_Std < Vhdl_08 then + Error_Msg_Parse ("generic packages not allowed before vhdl 2008"); + end if; + Set_Package_Header (Res, Parse_Package_Header); + end if; + + Parse_Declarative_Part (Res); + + End_Loc := Get_Token_Location; + + -- Skip 'end' + Expect_Scan (Tok_End); + + if Current_Token = Tok_Package then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("'package' keyword not allowed here by vhdl 87"); + end if; + Set_End_Has_Reserved_Id (Res, True); + + -- Skip 'package'. + Scan; + end if; + + Check_End_Name (Res); + Scan_Semi_Colon_Unit ("package declaration"); + + if Flag_Elocations then + Create_Elocations (Res); + Set_End_Location (Res, End_Loc); + end if; + + return Res; + end Parse_Package_Declaration; + + -- precond : BODY + -- postcond: next token. + -- + -- [ LRM93 2.6, LRM08 4.8 ] + -- package_body ::= + -- PACKAGE BODY PACKAGE_simple_name IS + -- package_body_declarative_part + -- END [ PACKAGE BODY ] [ PACKAGE_simple_name ] ; + function Parse_Package_Body (Parent : Iir) return Iir + is + Res : Iir; + End_Loc : Location_Type; + begin + Res := Create_Iir (Iir_Kind_Package_Body); + Set_Parent (Res, Parent); + + -- Get identifier. + Scan_Identifier (Res); + + -- Skip 'is'. + Expect_Scan (Tok_Is); + + Parse_Declarative_Part (Res); + + End_Loc := Get_Token_Location; + + -- Skip 'end' + Expect_Scan (Tok_End); + + if Current_Token = Tok_Package then + if Flags.Vhdl_Std = Vhdl_87 then + Error_Msg_Parse ("'package' keyword not allowed here by vhdl 87"); + end if; + Set_End_Has_Reserved_Id (Res, True); + + -- Skip 'package' + Scan; + + if Current_Token /= Tok_Body then + Error_Msg_Parse ("missing 'body' after 'package'"); + else + -- Skip 'body' + Scan; + end if; + end if; + + Check_End_Name (Res); + Scan_Semi_Colon_Unit ("package body"); + + if Flag_Elocations then + Create_Elocations (Res); + Set_End_Location (Res, End_Loc); + end if; + + return Res; + end Parse_Package_Body; + + -- precond : NEW + -- postcond: ';'. + -- + -- [ LRM08 4.9 ] + -- package_instantiation_declaration ::= + -- PACKAGE identifier IS NEW uninstantiated_package_name + -- [ generic_map_aspect ] ; + function Parse_Package_Instantiation_Declaration + (Parent : Iir; Id : Name_Id; Loc : Location_Type) return Iir + is + Res: Iir; + begin + Res := Create_Iir (Iir_Kind_Package_Instantiation_Declaration); + Set_Location (Res, Loc); + Set_Identifier (Res, Id); + Set_Parent (Res, Parent); + + -- Skip 'new' + Scan; + + Set_Uninstantiated_Package_Name (Res, Parse_Name (False)); + + if Current_Token = Tok_Generic then + Set_Generic_Map_Aspect_Chain (Res, Parse_Generic_Map_Aspect); + elsif Current_Token = Tok_Left_Paren then + Error_Msg_Parse ("missing 'generic map'"); + Set_Generic_Map_Aspect_Chain + (Res, Parse_Association_List_In_Parenthesis); + end if; + + if Flag_Elocations then + Create_Elocations (Res); + Set_End_Location (Res, Get_Token_Location); + end if; + + Scan_Semi_Colon_Unit ("package instantiation"); + + return Res; + end Parse_Package_Instantiation_Declaration; + + -- precond : PACKAGE + -- postcond: next token. + -- + -- package_declaration + -- | package_body + -- | package_instantiation_declaration + function Parse_Package (Parent : Iir) return Iir + is + Loc : Location_Type; + Id : Name_Id; + Res : Iir; + Start_Loc : Location_Type; + begin + -- Skip 'package' + Start_Loc := Get_Token_Location; + Scan; + + if Current_Token = Tok_Body then + -- Skip 'body' + Scan; + + Res := Parse_Package_Body (Parent); + else + Loc := Get_Token_Location; + if Current_Token = Tok_Identifier then + Id := Current_Identifier; + + -- Skip identifier. + Scan; + else + Expect (Tok_Identifier); + end if; + + -- Skip 'is'. + Expect_Scan (Tok_Is); + + if Current_Token = Tok_New then + Res := Parse_Package_Instantiation_Declaration (Parent, Id, Loc); + -- Note: there is no 'end' in instantiation. + else + Res := Parse_Package_Declaration (Parent, Id, Loc); + end if; + end if; + + if Flag_Elocations then + Set_Start_Location (Res, Start_Loc); + end if; + + return Res; + end Parse_Package; + + procedure Parse_Context_Declaration_Or_Reference + (Unit : Iir_Design_Unit; Clause : out Iir); + + -- Precond: next token + -- Postcond: next token + -- + -- [ LRM93 11.3, LRM08 13.4 Context clauses ] + -- context_clause ::= { context_item } + -- + -- context_item ::= library_clause | use_clause | context_reference + procedure Parse_Context_Clause (Unit : Iir) + is + use Context_Items_Chain_Handling; + Last : Iir; + Els : Iir; + begin + Build_Init (Last); + + loop + case Current_Token is + when Tok_Library => + Els := Parse_Library_Clause; + when Tok_Use => + Els := Parse_Use_Clause; + when Tok_Context => + Parse_Context_Declaration_Or_Reference (Unit, Els); + if Els = Null_Iir then + -- This was a context declaration. No more clause. + + -- LRM08 13.1 Design units + -- It is an error if the context clause preceding a library + -- unit that is a context declaration is not empty. + if Get_Context_Items (Unit) /= Null_Iir then + Error_Msg_Parse + (+Get_Context_Items (Unit), + "context declaration does not allow context " + & "clauses before it"); + end if; + + return; + end if; + when Tok_With => + -- Be Ada friendly. + Error_Msg_Parse ("'with' not allowed in context clause " + & "(try 'use' or 'library')"); + Els := Parse_Use_Clause; + when others => + exit; + end case; + Append_Subchain (Last, Unit, Els); + end loop; + end Parse_Context_Clause; + + -- Precond: IS + -- + -- [ LRM08 13.13 Context declarations ] + -- context_declaration ::= + -- CONTEXT identifier IS + -- context_clause + -- END [ CONTEXT ] [ /context/_simple_name ] ; + procedure Parse_Context_Declaration (Unit : Iir; Decl : Iir) + is + End_Loc : Location_Type; + begin + Set_Library_Unit (Unit, Decl); + + -- Skip 'is' + Scan; + + Parse_Context_Clause (Decl); + + Expect (Tok_End); + End_Loc := Get_Token_Location; + + -- Skip 'end' + Scan; + + if Current_Token = Tok_Context then + Set_End_Has_Reserved_Id (Decl, True); + + -- Skip 'context'. + Scan; + end if; + + Check_End_Name (Decl); + Scan_Semi_Colon_Unit ("context declaration"); + + if Flag_Elocations then + Create_Elocations (Decl); + Set_End_Location (Decl, End_Loc); + end if; + end Parse_Context_Declaration; + + -- Precond: next token after selected_name. + -- Postcond: next token + -- + -- [ LRM08 13.4 Context clauses ] + -- + -- context_reference ::= + -- CONTEXT selected_name { , selected_name } + function Parse_Context_Reference + (Loc : Location_Type; Name : Iir) return Iir + is + Ref : Iir; + First, Last : Iir; + begin + Ref := Create_Iir (Iir_Kind_Context_Reference); + Set_Location (Ref, Loc); + Set_Selected_Name (Ref, Name); + First := Ref; + Last := Ref; + + while Current_Token = Tok_Comma loop + -- Skip ','. + Scan; + + Ref := Create_Iir (Iir_Kind_Context_Reference); + Set_Location (Ref, Loc); + Set_Selected_Name (Ref, Parse_Name); + + Set_Context_Reference_Chain (Last, Ref); + Last := Ref; + end loop; + + Scan_Semi_Colon_Unit ("context reference"); + + return First; + end Parse_Context_Reference; + + -- Precond: CONTEXT + -- + procedure Parse_Context_Declaration_Or_Reference + (Unit : Iir_Design_Unit; Clause : out Iir) + is + Loc : Location_Type; + Name : Iir; + Res : Iir; + begin + Loc := Get_Token_Location; + + -- Skip 'context'. + Scan; + + Name := Parse_Name; + + if Current_Token = Tok_Is then + Res := Create_Iir (Iir_Kind_Context_Declaration); + if Get_Kind (Name) = Iir_Kind_Simple_Name then + Location_Copy (Res, Name); + Set_Identifier (Res, Get_Identifier (Name)); + else + Set_Location (Res, Loc); + Error_Msg_Parse (+Name, "identifier for context expected"); + end if; + Free_Iir (Name); + + Parse_Context_Declaration (Unit, Res); + Clause := Null_Iir; + else + Clause := Parse_Context_Reference (Loc, Name); + end if; + end Parse_Context_Declaration_Or_Reference; + + -- Parse a design_unit. + -- The lexical scanner must have been initialized, but without a + -- current_token. + -- + -- [ LRM93 11.1 ] + -- design_unit ::= context_clause library_unit + function Parse_Design_Unit return Iir_Design_Unit + is + procedure Error_Empty is + begin + Error_Msg_Parse + ("missing entity, architecture, package or configuration"); + end Error_Empty; + + Res: Iir_Design_Unit; + Unit: Iir; + begin + pragma Assert (Parenthesis_Depth = 0); + + -- Create the design unit node. + Res := Create_Iir (Iir_Kind_Design_Unit); + Set_Location (Res); + Set_Date_State (Res, Date_Extern); + + Parse_Context_Clause (Res); + + if Get_Library_Unit (Res) = Null_Iir then + -- Parse library unit. Context declaration are already parsed. + case Current_Token is + when Tok_Entity => + Parse_Entity_Declaration (Res); + when Tok_Architecture => + Parse_Architecture_Body (Res); + when Tok_Package => + Set_Library_Unit (Res, Parse_Package (Res)); + when Tok_Configuration => + Parse_Configuration_Declaration (Res); + when Tok_Identifier => + if Current_Identifier = Name_Context then + Error_Msg_Parse + ("context clause not allowed before vhdl 08"); + else + Error_Empty; + end if; + Resync_To_Next_Unit; + return Res; + when others => + Error_Empty; + Resync_To_Next_Unit; + return Res; + end case; + end if; + + Unit := Get_Library_Unit (Res); + Set_Design_Unit (Unit, Res); + Set_Identifier (Res, Get_Identifier (Unit)); + Set_Date (Res, Date_Parsed); + return Res; + end Parse_Design_Unit; + + -- [ LRM93 11.1 ] + -- design_file ::= design_unit { design_unit } + function Parse_Design_File return Iir_Design_File + is + Res : Iir_Design_File; + Design, Last_Design : Iir_Design_Unit; + begin + -- The first token. + pragma Assert (Current_Token = Tok_Invalid); + Scan; + + Res := Create_Iir (Iir_Kind_Design_File); + Set_Location (Res); + + Last_Design := Null_Iir; + while Current_Token /= Tok_Eof loop + Design := Parse_Design_Unit; + Set_Design_File (Design, Res); + + -- Append unit to the design file. + if Last_Design = Null_Iir then + Set_First_Design_Unit (Res, Design); + else + Set_Chain (Last_Design, Design); + end if; + Last_Design := Design; + Set_Last_Design_Unit (Res, Last_Design); + end loop; + + if Last_Design = Null_Iir then + Error_Msg_Parse ("design file is empty (no design unit found)"); + end if; + + return Res; + end Parse_Design_File; +end Vhdl.Parse; diff --git a/src/vhdl/vhdl-parse.ads b/src/vhdl/vhdl-parse.ads new file mode 100644 index 000000000..c399fc475 --- /dev/null +++ b/src/vhdl/vhdl-parse.ads @@ -0,0 +1,63 @@ +-- VHDL parser. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; +with Iirs; use Iirs; + +package Vhdl.Parse is + -- If True, create nodes for parenthesis expressions. + Flag_Parse_Parenthesis : Boolean := False; + + type Prio_Type is + ( + Prio_Expression, + Prio_Logical, + Prio_Relation, + Prio_Shift, + Prio_Simple, + Prio_Term, + Prio_Factor + ); + + -- Parse an expression. + -- (Used by PSL). + function Parse_Expression (Prio : Prio_Type := Prio_Expression) return Iir; + function Parse_Binary_Expression (Left : Iir; Prio : Prio_Type) return Iir; + + -- Convert the STR (0 .. LEN - 1) into a operator symbol identifier. + -- Emit an error message if the name is not an operator name. + function Str_To_Operator_Name (Str_Id : String8_Id; + Len : Nat32; + Loc : Location_Type) return Name_Id; + + -- Convert string literal STR to an operator symbol. + -- Emit an error message if the string is not an operator name. + function String_To_Operator_Symbol (Str : Iir) return Iir; + + -- Parse a single design unit. + -- The scanner must have been initialized, however, the current_token + -- shouldn't have been set. + -- At return, the last token accepted is the semi_colon that terminates + -- the library unit. + -- Return Null_Iir when end of file. + function Parse_Design_Unit return Iir_Design_Unit; + + -- Parse a file. + -- The scanner must have been initialized as for parse_design_unit. + -- Return Null_Iir in case of error. + function Parse_Design_File return Iir_Design_File; +end Vhdl.Parse; diff --git a/src/vhdl/vhdl-parse_psl.adb b/src/vhdl/vhdl-parse_psl.adb new file mode 100644 index 000000000..f20094231 --- /dev/null +++ b/src/vhdl/vhdl-parse_psl.adb @@ -0,0 +1,867 @@ +-- VHDL PSL parser. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Errorout; use Errorout; +with PSL.Nodes; use PSL.Nodes; +with Iirs; +with Vhdl.Scanner; use Vhdl.Scanner; +with PSL.Errors; use PSL.Errors; +with PSL.Priorities; use PSL.Priorities; +with Vhdl.Parse; + +package body Vhdl.Parse_Psl is + procedure Error_Msg_Parse (Msg: String) is + begin + Report_Msg (Msgid_Error, Errorout.Parse, No_Location, Msg); + end Error_Msg_Parse; + + procedure Error_Msg_Parse + (Loc : Location_Type; Msg: String; Args : Earg_Arr := No_Eargs) is + begin + Report_Msg (Msgid_Error, Errorout.Parse, Loc, Msg, Args); + end Error_Msg_Parse; + + function Create_Node_Loc (K : Nkind) return Node is + Res : Node; + begin + Res := PSL.Nodes.Create_Node (K); + Set_Location (Res, Get_Token_Location); + return Res; + end Create_Node_Loc; + + function Parse_Number return Node is + Res : Node; + begin + if Current_Token = Tok_Integer then + Res := Create_Node_Loc (N_Number); + -- FIXME: handle overflow. + Set_Value (Res, Uns32 (Current_Iir_Int64)); + Scan; + return Res; + elsif Current_Token = Tok_Inf then + -- FIXME: create node + Scan; + return Null_Node; + else + Error_Msg_Parse ("number expected"); + return Null_Node; + end if; + end Parse_Number; + + procedure Parse_Count (N : Node) is + begin + Set_Low_Bound (N, Parse_Number); + if Current_Token = Tok_To then + Scan; + Set_High_Bound (N, Parse_Number); + end if; + end Parse_Count; + + function Psl_To_Vhdl (N : Node) return Iirs.Iir; + + function Binary_Psl_Operator_To_Vhdl (N : Node; Kind : Iirs.Iir_Kind) + return Iirs.Iir + is + use Iirs; + Res : Iir; + begin + Res := Create_Iir (Kind); + Set_Location (Res, Get_Location (N)); + Set_Left (Res, Psl_To_Vhdl (Get_Left (N))); + Set_Right (Res, Psl_To_Vhdl (Get_Right (N))); + return Res; + end Binary_Psl_Operator_To_Vhdl; + + function Psl_To_Vhdl (N : Node) return Iirs.Iir + is + use Iirs; + Res : Iir; + begin + case Get_Kind (N) is + when N_HDL_Expr => + Res := Iirs.Iir (Get_HDL_Node (N)); + when N_And_Prop => + Res := Binary_Psl_Operator_To_Vhdl (N, Iir_Kind_And_Operator); + when N_Or_Prop => + Res := Binary_Psl_Operator_To_Vhdl (N, Iir_Kind_Or_Operator); + when others => + Error_Msg_Parse + (+N, "PSL construct not allowed as VHDL expression"); + Res := Create_Iir (Iir_Kind_Error); + Set_Location (Res, Get_Location (N)); + end case; + Free_Node (N); + return Res; + end Psl_To_Vhdl; + + function Vhdl_To_Psl (N : Iirs.Iir) return Node + is + use Iirs; + Res : Node; + begin + Res := Create_Node_Loc (N_HDL_Expr); + if N /= Null_Iir then + Set_Location (Res, Get_Location (N)); + Set_HDL_Node (Res, Int32 (N)); + end if; + return Res; + end Vhdl_To_Psl; + + function Parse_FL_Property (Prio : Priority) return Node; + function Parse_Parenthesis_Boolean return Node; + function Parse_Boolean (Parent_Prio : Priority) return Node; + + function Parse_Unary_Boolean (Full_Hdl_Expr : Boolean) return Node + is + use Parse; + use Iirs; + Left, Expr : Iir; + Op : Iir_Kind; + begin + if Full_Hdl_Expr then + Expr := Parse_Expression; + else + -- Boolean operators must be parse, *except* and/or that could be at + -- upper layers (FL). + Expr := Parse_Expression (Prio_Relation); + loop + case Current_Token is + when Tok_Xor => + Op := Iir_Kind_Xor_Operator; + when Tok_Nand => + Op := Iir_Kind_Nand_Operator; + when Tok_Nor => + Op := Iir_Kind_Nor_Operator; + when Tok_Xnor => + Op := Iir_Kind_Xnor_Operator; + when others => + exit; + end case; + + Left := Expr; + Expr := Create_Iir (Op); + Set_Location (Expr, Get_Token_Location); + Set_Left (Expr, Left); + + -- Skip operator. + Scan; + + Set_Right (Expr, Parse_Expression (Prio_Relation)); + end loop; + end if; + + return Vhdl_To_Psl (Expr); + end Parse_Unary_Boolean; + + function Parse_Boolean_Rhs (Parent_Prio : Priority; Left : Node) return Node + is + Kind : Nkind; + Prio : Priority; + Res : Node; + Tmp : Node; + begin + Res := Left; + loop + case Current_Token is + when Tok_And => + Kind := N_And_Bool; + Prio := Prio_Seq_And; + when Tok_Or => + Kind := N_Or_Bool; + Prio := Prio_Seq_Or; + when others => + return Res; + end case; + if Parent_Prio >= Prio then + return Res; + end if; + Tmp := Create_Node_Loc (Kind); + Scan; + Set_Left (Tmp, Res); + Res := Tmp; + Tmp := Parse_Boolean (Prio); + Set_Right (Res, Tmp); + end loop; + end Parse_Boolean_Rhs; + + function Parse_Boolean (Parent_Prio : Priority) return Node + is + begin + return Parse_Boolean_Rhs (Parent_Prio, Parse_Unary_Boolean (False)); + end Parse_Boolean; + + function Parse_Psl_Boolean return PSL_Node is + begin + return Parse_Boolean (Prio_Lowest); + end Parse_Psl_Boolean; + + function Parse_Parenthesis_Boolean return Node is + Res : Node; + begin + if Current_Token /= Tok_Left_Paren then + Error_Msg_Parse ("'(' expected before boolean expression"); + return Null_Node; + else + Scan; + Res := Parse_Psl_Boolean; + if Current_Token = Tok_Right_Paren then + Scan; + else + Error_Msg_Parse ("missing matching ')' for boolean expression"); + end if; + return Res; + end if; + end Parse_Parenthesis_Boolean; + + function Parse_SERE (Prio : Priority) return Node is + Left, Res : Node; + Kind : Nkind; + Op_Prio : Priority; + begin + Left := Parse_Psl_Sequence (True); + loop + case Current_Token is + when Tok_Semi_Colon => + Kind := N_Concat_SERE; + Op_Prio := Prio_Seq_Concat; + when Tok_Colon => + Kind := N_Fusion_SERE; + Op_Prio := Prio_Seq_Fusion; + when Tok_Within => + Kind := N_Within_SERE; + Op_Prio := Prio_Seq_Within; + when Tok_Ampersand => + -- For non-length matching and, the operator is '&'. + Kind := N_And_Seq; + Op_Prio := Prio_Seq_And; + when Tok_And_And => + Kind := N_Match_And_Seq; + Op_Prio := Prio_Seq_And; + when Tok_Bar => + Kind := N_Or_Seq; + Op_Prio := Prio_Seq_Or; +-- when Tok_Bar_Bar => +-- Res := Create_Node_Loc (N_Or_Bool); +-- Scan; +-- Set_Left (Res, Left); +-- Set_Right (Res, Parse_Boolean (Prio_Seq_Or)); +-- return Res; + when others => + return Left; + end case; + if Prio >= Op_Prio then + return Left; + end if; + Res := Create_Node_Loc (Kind); + Scan; + Set_Left (Res, Left); + Set_Right (Res, Parse_SERE (Op_Prio)); + Left := Res; + end loop; + end Parse_SERE; + + -- precond : '{' + -- postcond: next token after '}' + function Parse_Braced_SERE return Node is + Res : Node; + begin + pragma Assert (Current_Token = Tok_Left_Curly); + Res := Create_Node_Loc (N_Braced_SERE); + + -- Skip '{' + Scan; + + Set_SERE (Res, Parse_SERE (Prio_Lowest)); + + if Current_Token /= Tok_Right_Curly then + Error_Msg_Parse ("missing '}' after braced SERE"); + else + -- Skip '}' + Scan; + end if; + return Res; + end Parse_Braced_SERE; + + -- Parse [ Count ] ']' + function Parse_Maybe_Count (Kind : Nkind; Seq : Node) return Node is + N : Node; + begin + N := Create_Node_Loc (Kind); + Set_Sequence (N, Seq); + Scan; + if Current_Token /= Tok_Right_Bracket then + Parse_Count (N); + end if; + if Current_Token /= Tok_Right_Bracket then + Error_Msg_Parse ("missing ']'"); + else + Scan; + end if; + return N; + end Parse_Maybe_Count; + + procedure Parse_Bracket_Range (N : Node) is + begin + if Current_Token /= Tok_Left_Bracket then + Error_Msg_Parse ("'[' expected"); + else + Scan; + Set_Low_Bound (N, Parse_Number); + if Current_Token /= Tok_To then + Error_Msg_Parse ("'to' expected in range after left bound"); + else + Scan; + Set_High_Bound (N, Parse_Number); + end if; + if Current_Token /= Tok_Right_Bracket then + Error_Msg_Parse ("']' expected after range"); + else + Scan; + end if; + end if; + end Parse_Bracket_Range; + + function Parse_Bracket_Number return Node is + Res : Node; + begin + if Current_Token /= Tok_Left_Bracket then + Error_Msg_Parse ("'[' expected"); + return Null_Node; + else + Scan; + Res := Parse_Number; + if Current_Token /= Tok_Right_Bracket then + Error_Msg_Parse ("']' expected after range"); + else + Scan; + end if; + return Res; + end if; + end Parse_Bracket_Number; + + function Parse_Psl_Sequence (Full_Hdl_Expr : Boolean) return Node is + Res, N : Node; + begin + case Current_Token is + when Tok_Left_Curly => + Res := Parse_Braced_SERE; + if Current_Token = Tok_Arobase then + N := Create_Node_Loc (N_Clocked_SERE); + Set_SERE (N, Res); + + -- Skip '@' + Scan; + + Set_Boolean (N, Parse_Psl_Boolean); + Res := N; + end if; + when Tok_Brack_Star => + return Parse_Maybe_Count (N_Star_Repeat_Seq, Null_Node); + when Tok_Left_Paren => + Res := Parse_Parenthesis_Boolean; + if Current_Token = Tok_Or + or else Current_Token = Tok_And + then + Res := Parse_Boolean_Rhs (Prio_Lowest, Res); + end if; + when Tok_Brack_Plus_Brack => + Res := Create_Node_Loc (N_Plus_Repeat_Seq); + Scan; + return Res; + when others => + -- Repeated_SERE + Res := Parse_Unary_Boolean (Full_Hdl_Expr); + end case; + loop + case Current_Token is + when Tok_Brack_Star => + Res := Parse_Maybe_Count (N_Star_Repeat_Seq, Res); + when Tok_Brack_Plus_Brack => + N := Create_Node_Loc (N_Plus_Repeat_Seq); + Set_Sequence (N, Res); + + -- Skip '[+]' + Scan; + Res := N; + when Tok_Brack_Arrow => + Res := Parse_Maybe_Count (N_Goto_Repeat_Seq, Res); + when Tok_Brack_Equal => + N := Create_Node_Loc (N_Equal_Repeat_Seq); + Set_Sequence (N, Res); + + -- Skip '[=' + Scan; + Parse_Count (N); + if Current_Token /= Tok_Right_Bracket then + Error_Msg_Parse ("missing ']'"); + else + Scan; + end if; + Res := N; + when others => + return Res; + end case; + end loop; + end Parse_Psl_Sequence; + + -- precond: '(' + -- postcond: next token + function Parse_Parenthesis_FL_Property return Node is + Res : Node; + Loc : Location_Type; + begin + Loc := Get_Token_Location; + if Current_Token /= Tok_Left_Paren then + Error_Msg_Parse ("'(' expected around property"); + return Parse_FL_Property (Prio_Lowest); + else + -- Skip '('. + Scan; + + Res := Parse_FL_Property (Prio_Lowest); + if Current_Token = Tok_Right_Paren then + -- Skip ')'. + Scan; + else + Error_Msg_Parse ("missing matching ')' for '(' at line " + & Image (Loc, False)); + end if; + + if Get_Kind (Res) = N_HDL_Expr then + declare + N : Iirs.Iir; + begin + N := Psl_To_Vhdl (Res); + N := Parse.Parse_Binary_Expression (N, Parse.Prio_Expression); + Res := Vhdl_To_Psl (N); + end; + end if; + return Res; + end if; + end Parse_Parenthesis_FL_Property; + + -- Parse [ '!' ] '[' finite_Range ']' '(' FL_Property ')' + function Parse_Range_Property (K : Nkind) return Node is + Res : Node; + begin + Res := Create_Node_Loc (K); + Set_Strong_Flag (Res, Scan_Exclam_Mark); + Scan; + Parse_Bracket_Range (Res); + Set_Property (Res, Parse_Parenthesis_FL_Property); + return Res; + end Parse_Range_Property; + + -- Parse [ '!' ] '(' Boolean ')' '[' Range ']' '(' FL_Property ')' + function Parse_Boolean_Range_Property (K : Nkind) return Node is + Res : Node; + begin + Res := Create_Node_Loc (K); + Set_Strong_Flag (Res, Scan_Exclam_Mark); + Scan; + Set_Boolean (Res, Parse_Parenthesis_Boolean); + Parse_Bracket_Range (Res); + Set_Property (Res, Parse_Parenthesis_FL_Property); + return Res; + end Parse_Boolean_Range_Property; + + function Parse_FL_Property_1 return Node + is + Res : Node; + Tmp : Node; + begin + case Current_Token is + when Tok_Always => + Res := Create_Node_Loc (N_Always); + Scan; + Set_Property (Res, Parse_FL_Property (Prio_FL_Invariance)); + when Tok_Never => + Res := Create_Node_Loc (N_Never); + Scan; + Set_Property (Res, Parse_FL_Property (Prio_FL_Invariance)); + when Tok_Eventually => + Res := Create_Node_Loc (N_Eventually); + if not Scan_Exclam_Mark then + Error_Msg_Parse ("'eventually' must be followed by '!'"); + end if; + Scan; + Set_Property (Res, Parse_FL_Property (Prio_FL_Occurence)); + when Tok_Next => + Res := Create_Node_Loc (N_Next); + Scan; + if Current_Token = Tok_Left_Bracket then + Set_Number (Res, Parse_Bracket_Number); + Set_Property (Res, Parse_Parenthesis_FL_Property); + else + Set_Property (Res, Parse_FL_Property (Prio_FL_Occurence)); + end if; + when Tok_Next_A => + Res := Parse_Range_Property (N_Next_A); + when Tok_Next_E => + Res := Parse_Range_Property (N_Next_E); + when Tok_Next_Event => + Res := Create_Node_Loc (N_Next_Event); + Scan; + Set_Boolean (Res, Parse_Parenthesis_Boolean); + if Current_Token = Tok_Left_Bracket then + Set_Number (Res, Parse_Bracket_Number); + end if; + Set_Property (Res, Parse_Parenthesis_FL_Property); + when Tok_Next_Event_A => + Res := Parse_Boolean_Range_Property (N_Next_Event_A); + when Tok_Next_Event_E => + Res := Parse_Boolean_Range_Property (N_Next_Event_E); + when Tok_Left_Paren => + return Parse_Parenthesis_FL_Property; + when Tok_Left_Curly => + Res := Parse_Psl_Sequence (True); + if Get_Kind (Res) = N_Braced_SERE + and then Current_Token = Tok_Left_Paren + then + -- FIXME: must check that RES is really a sequence + -- (and not a SERE). + Tmp := Create_Node_Loc (N_Overlap_Imp_Seq); + Set_Sequence (Tmp, Res); + Set_Property (Tmp, Parse_Parenthesis_FL_Property); + Res := Tmp; + end if; + when others => + Res := Parse_Psl_Sequence (False); + end case; + return Res; + end Parse_FL_Property_1; + + function Parse_St_Binary_FL_Property (K : Nkind; Left : Node) return Node is + Res : Node; + begin + Res := Create_Node_Loc (K); + Set_Strong_Flag (Res, Scan_Exclam_Mark); + Set_Inclusive_Flag (Res, Scan_Underscore); + Scan; + Set_Left (Res, Left); + Set_Right (Res, Parse_FL_Property (Prio_FL_Bounding)); + return Res; + end Parse_St_Binary_FL_Property; + + function Parse_Binary_FL_Property (K : Nkind; Left : Node; Prio : Priority) + return Node + is + Res : Node; + begin + Res := Create_Node_Loc (K); + Scan; + Set_Left (Res, Left); + Set_Right (Res, Parse_FL_Property (Prio)); + return Res; + end Parse_Binary_FL_Property; + + -- During LR parsing, phrases before |-> and |=> are parsed as properties, + -- but they are in fact sequences. Convert them (in particular the + -- boolean operators need to be rewritten). + function Property_To_Sequence (N : Node) return Node + is + procedure Rewrite_Binary (Res : Node; N : Node) is + begin + Set_Location (Res, Get_Location (N)); + Set_Left (Res, Property_To_Sequence (Get_Left (N))); + Set_Right (Res, Property_To_Sequence (Get_Right (N))); + Free_Node (N); + end Rewrite_Binary; + Res : Node; + begin + case Get_Kind (N) is + when N_And_Prop => + Res := Create_Node (N_And_Seq); + Rewrite_Binary (Res, N); + return Res; + when N_Or_Prop => + Res := Create_Node (N_Or_Seq); + Rewrite_Binary (Res, N); + return Res; + when N_Before => + Set_Left (N, Property_To_Sequence (Get_Left (N))); + Set_Right (N, Property_To_Sequence (Get_Right (N))); + return N; + when N_Clock_Event + | N_Always + | N_Never + | N_Eventually + | N_Until + | N_Property_Parameter + | N_Property_Instance + | N_Endpoint_Instance + | N_Strong + | N_Abort + | N_Next_Event_E + | N_Next_Event_A + | N_Next_Event + | N_Next_E + | N_Next_A + | N_Next + | N_Log_Imp_Prop => + Error_Msg_Parse (+N, "construct not allowed in sequences"); + return N; + when N_Const_Parameter + | N_Boolean_Parameter + | N_Sequence_Parameter + | N_Sequence_Instance + | N_Actual + | N_And_Seq + | N_Or_Seq + | N_Imp_Seq + | N_Overlap_Imp_Seq + | N_Match_And_Seq + | N_Star_Repeat_Seq + | N_Goto_Repeat_Seq + | N_Equal_Repeat_Seq + | N_Plus_Repeat_Seq + | N_Imp_Bool + | N_Or_Bool + | N_And_Bool + | N_Not_Bool + | N_Fusion_SERE + | N_HDL_Expr + | N_Hdl_Mod_Name + | N_Braced_SERE + | N_Concat_SERE + | N_Within_SERE + | N_Clocked_SERE + | N_False + | N_True + | N_Number + | N_Name_Decl + | N_Name + | N_EOS + | N_Error => + return N; + when N_Vmode + | N_Vunit + | N_Vprop + | N_Assert_Directive + | N_Property_Declaration + | N_Sequence_Declaration + | N_Endpoint_Declaration => + raise Internal_Error; + end case; + end Property_To_Sequence; + + function Parse_FL_Property (Prio : Priority) return Node + is + Res : Node; + N : Node; + begin + Res := Parse_FL_Property_1; + loop + case Current_Token is + when Tok_Minus_Greater => + if Prio > Prio_Bool_Imp then + return Res; + end if; + N := Create_Node_Loc (N_Log_Imp_Prop); + Set_Left (N, Res); + Scan; + Set_Right (N, Parse_FL_Property (Prio_Bool_Imp)); + Res := N; + when Tok_Bar_Arrow => + if Prio > Prio_Seq_Imp then + return Res; + end if; + N := Create_Node_Loc (N_Overlap_Imp_Seq); + Set_Sequence (N, Property_To_Sequence (Res)); + Scan; + Set_Property (N, Parse_FL_Property (Prio_Seq_Imp)); + Res := N; + when Tok_Bar_Double_Arrow => + if Prio > Prio_Seq_Imp then + return Res; + end if; + N := Create_Node_Loc (N_Imp_Seq); + Set_Sequence (N, Property_To_Sequence (Res)); + Scan; + Set_Property (N, Parse_FL_Property (Prio_Seq_Imp)); + Res := N; + when Tok_Abort => + if Prio > Prio_FL_Abort then + return Res; + end if; + N := Create_Node_Loc (N_Abort); + Set_Property (N, Res); + Scan; + Set_Boolean (N, Parse_Boolean (Prio_Lowest)); + -- Left associative. + return N; + when Tok_Exclam_Mark => + N := Create_Node_Loc (N_Strong); + Set_Property (N, Res); + Scan; + Res := N; + when Tok_Until => + if Prio > Prio_FL_Bounding then + return Res; + end if; + Res := Parse_St_Binary_FL_Property (N_Until, Res); + when Tok_Before => + if Prio > Prio_FL_Bounding then + return Res; + end if; + Res := Parse_St_Binary_FL_Property (N_Before, Res); + when Tok_Or => + if Prio > Prio_Seq_Or then + return Res; + end if; + Res := Parse_Binary_FL_Property (N_Or_Prop, Res, Prio_Seq_Or); + when Tok_And => + if Prio > Prio_Seq_And then + return Res; + end if; + Res := Parse_Binary_FL_Property (N_And_Prop, Res, Prio_Seq_And); + when Token_Relational_Operator_Type => + return Vhdl_To_Psl + (Parse.Parse_Binary_Expression + (Psl_To_Vhdl (Res), Parse.Prio_Relation)); + when Tok_Colon + | Tok_Bar + | Tok_Ampersand + | Tok_And_And => + Error_Msg_Parse ("SERE operator '" & Image (Current_Token) + & "' is not allowed in property"); + Scan; + N := Parse_FL_Property (Prio_Lowest); + return Res; + when Tok_Arobase => + if Prio > Prio_Clock_Event then + return Res; + end if; + N := Create_Node_Loc (N_Clock_Event); + Set_Property (N, Res); + Scan; + Set_Boolean (N, Parse_Boolean (Prio_Clock_Event)); + Res := N; + when others => + return Res; + end case; + end loop; + end Parse_FL_Property; + + function Parse_Psl_Property return PSL_Node is + begin + return Parse_FL_Property (Prio_Lowest); + end Parse_Psl_Property; + + -- precond: identifier + -- postcond: ';' + -- + -- 6.2.4.1 Property declaration + -- + -- Property_Declaration ::= + -- PROPERTY psl_identifier [ ( Formal_Parameter_List ) ] DEF_SYM + -- property ; + function Parse_Psl_Declaration (Tok : Token_Type) return PSL_Node + is + Res : Node; + Param : Node; + Last_Param : Node; + Pkind : Nkind; + Kind : Nkind; + begin + case Tok is + when Tok_Psl_Property => + Kind := N_Property_Declaration; + when Tok_Psl_Sequence => + Kind := N_Sequence_Declaration; + when Tok_Psl_Endpoint => + Kind := N_Endpoint_Declaration; + when others => + raise Internal_Error; + end case; + Res := Create_Node_Loc (Kind); + if Current_Token = Tok_Identifier then + Set_Identifier (Res, Current_Identifier); + Scan; + end if; + + -- Formal parameter list. + if Current_Token = Tok_Left_Paren then + Last_Param := Null_Node; + loop + -- precond: '(' or ';'. + Scan; + case Current_Token is + when Tok_Psl_Const => + Pkind := N_Const_Parameter; + when Tok_Psl_Boolean => + Pkind := N_Boolean_Parameter; + when Tok_Psl_Property => + Pkind := N_Property_Parameter; + when Tok_Psl_Sequence => + Pkind := N_Sequence_Parameter; + when others => + Error_Msg_Parse ("parameter type expected"); + end case; + + -- Formal parameters. + loop + -- precond: parameter_type or ',' + Scan; + Param := Create_Node_Loc (Pkind); + if Current_Token /= Tok_Identifier then + Error_Msg_Parse ("identifier for parameter expected"); + else + Set_Identifier (Param, Current_Identifier); + end if; + if Last_Param = Null_Node then + Set_Parameter_List (Res, Param); + else + Set_Chain (Last_Param, Param); + end if; + Last_Param := Param; + Scan; + exit when Current_Token /= Tok_Comma; + end loop; + exit when Current_Token = Tok_Right_Paren; + if Current_Token /= Tok_Semi_Colon then + Error_Msg_Parse ("';' expected between formal parameter"); + end if; + + end loop; + Scan; + end if; + + if Current_Token /= Tok_Is then + Error_Msg_Parse ("'is' expected after identifier"); + else + -- Skip 'is'. + Scan; + end if; + case Kind is + when N_Property_Declaration => + Set_Property (Res, Parse_Psl_Property); + when N_Sequence_Declaration + | N_Endpoint_Declaration => + Set_Sequence (Res, Parse_Psl_Sequence (True)); + when others => + raise Internal_Error; + end case; + return Res; + end Parse_Psl_Declaration; + + function Is_Instantiated_Declaration (N : PSL_Node) return Boolean is + begin + return Get_Parameter_List (N) = Null_Node; + end Is_Instantiated_Declaration; +end Vhdl.Parse_Psl; diff --git a/src/vhdl/vhdl-parse_psl.ads b/src/vhdl/vhdl-parse_psl.ads new file mode 100644 index 000000000..717663ecc --- /dev/null +++ b/src/vhdl/vhdl-parse_psl.ads @@ -0,0 +1,30 @@ +-- VHDL PSL parser. +-- Copyright (C) 2009 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Types; use Types; +with Vhdl.Tokens; use Vhdl.Tokens; + +package Vhdl.Parse_Psl is + function Parse_Psl_Sequence (Full_Hdl_Expr : Boolean) return PSL_Node; + function Parse_Psl_Property return PSL_Node; + function Parse_Psl_Boolean return PSL_Node; + function Parse_Psl_Declaration (Tok : Token_Type) return PSL_Node; + + -- True if endpoint declaration N is instantiated (ie has no parameters). + function Is_Instantiated_Declaration (N : PSL_Node) return Boolean; +end Vhdl.Parse_Psl; -- cgit v1.2.3