Subversion Repositories scarts

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             P A R . E N D H                              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 2,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT 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  distributed with GNAT;  see file COPYING.  If not, write --

-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --

-- Boston, MA 02110-1301, USA.                                              --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

with Stringt; use Stringt;

with Uintp;   use Uintp;

with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;

separate (Par)

package body Endh is

   ----------------

   -- Local Data --

   ----------------

   type End_Action_Type is (

   --  Type used to describe the result of the Pop_End_Context call

      Accept_As_Scanned,

      --  Current end sequence is entirely c correct. In this case Token and

      --  the scan pointer are left pointing past the end sequence (i.e. they

      --  are unchanged from the values set on entry to Pop_End_Context).

      Insert_And_Accept,

      --  Current end sequence is to be left in place to satisfy some outer

      --  scope. Token and the scan pointer are set to point to the end

      --  token, and should be left there. A message has been generated

      --  indicating a missing end sequence. This status is also used for

      --  the case when no end token is present.

      Skip_And_Accept,

      --  The end sequence is incorrect (and an error message has been

      --  posted), but it will still be accepted. In this case Token and

      --  the scan pointer point back to the end token, and the caller

      --  should skip past the end sequence before proceeding.

      Skip_And_Reject);

      --  The end sequence is judged to belong to an unrecognized inner

      --  scope. An appropriate message has been issued and the caller

      --  should skip past the end sequence and then proceed as though

      --  no end sequence had been encountered.

   End_Action : End_Action_Type;

   --  The variable set by Pop_End_Context call showing which of the four

   --  decisions described above is judged the best.

   End_Sloc : Source_Ptr;

   --  Source location of END token

   End_OK : Boolean;

   --  Set False if error is found in END line

   End_Column : Column_Number;

   --  Column of END line

   End_Type : SS_End_Type;

   --  Type of END expected. The special value E_Dummy is set to indicate that

   --  no END token was present (so a missing END inserted message is needed)

   End_Labl : Node_Id;

   --  Node_Id value for explicit name on END line, or for compiler supplied

   --  name in the case where an optional name is not given. Empty if no name

   --  appears. If non-empty, then it is either an N_Designator node for a

   --  child unit or a node with a Chars field identifying the actual label.

   End_Labl_Present : Boolean;

   --  Indicates that the value in End_Labl was for an explicit label

   Syntax_OK : Boolean;

   --  Set True if the entry is syntactically correct

   Token_OK : Boolean;

   --  Set True if the keyword in the END sequence matches, or if neither

   --  the END sequence nor the END stack entry has a keyword.

   Label_OK : Boolean;

   --  Set True if both the END sequence and the END stack entry contained

   --  labels (other than No_Name or Error_Name) and the labels matched.

   --  This is a stronger condition than SYNTAX_OK, since it means that a

   --  label was present, even in a case where it was optional. Note that

   --  the case of no label required, and no label present does NOT set

   --  Label_OK to True, it is True only if a positive label match is found.

   Column_OK : Boolean;

   --  Column_OK is set True if the END sequence appears in the expected column

   Scan_State : Saved_Scan_State;

   --  Save state at start of END sequence, in case we decide not to eat it up

   -----------------------

   -- Local Subprograms --

   -----------------------

   procedure Evaluate_End_Entry (SS_Index : Nat);

   --  Compare scanned END entry (as recorded by a prior call to P_End_Scan)

   --  with a specified entry in the scope stack (the single parameter is the

   --  entry index in the scope stack). Note that Scan is not called. The above

   --  variables xxx_OK are set to indicate the result of the evaluation.

   function Explicit_Start_Label (SS_Index : Nat) return Boolean;

   --  Determines whether the specified entry in the scope stack has an

   --  explicit start label (i.e. one other than one that was created by

   --  the parser when no explicit label was present)

   procedure Output_End_Deleted;

   --  Output a message complaining that the current END structure does not

   --  match anything and is being deleted.

   procedure Output_End_Expected (Ins : Boolean);

   --  Output a message at the start of the current token which is always an

   --  END, complaining that the END is not of the right form. The message

   --  indicates the expected form. The information for the message is taken

   --  from the top entry in the scope stack. The Ins parameter is True if

   --  an end is being inserted, and false if an existing end is being

   --  replaced. Note that in the case of a suspicious IS for the Ins case,

   --  we do not output the message, but instead simply mark the scope stack

   --  entry as being a case of a bad IS.

   procedure Output_End_Missing;

   --  Output a message just before the current token, complaining that the

   --  END is not of the right form. The message indicates the expected form.

   --  The information for the message is taken from the top entry in the

   --  scope stack. Note that in the case of a suspicious IS, we do not output

   --  the message, but instead simply mark the scope stack entry as a bad IS.

   procedure Pop_End_Context;

   --  Pop_End_Context is called after processing a construct, to pop the

   --  top entry off the end stack. It decides on the appropriate action to

   --  to take, signalling the result by setting End_Action as described in

   --  the global variable section.

   function Same_Label (Label1, Label2 : Node_Id) return Boolean;

   --  This function compares the two names associated with the given nodes.

   --  If they are both simple (i.e. have Chars fields), then they have to

   --  be the same name. Otherwise they must both be N_Selected_Component

   --  nodes, referring to the same set of names, or Label1 is an N_Designator

   --  referring to the same set of names as the N_Defining_Program_Unit_Name

   --  in Label2. Any other combination returns False. This routine is used

   --  to compare the End_Labl scanned from the End line with the saved label

   --  value in the scope stack.

   ---------------

   -- Check_End --

   ---------------

   function Check_End return Boolean is

      Name_On_Separate_Line : Boolean;

      --  Set True if the name on an END line is on a separate source line

      --  from the END. This is highly suspicious, but is allowed. The point

      --  is that we want to make sure that we don't just have a missing

      --  semicolon misleading us into swallowing an identifier from the

      --  following line.

      Name_Scan_State : Saved_Scan_State;

      --  Save state at start of name if Name_On_Separate_Line is TRUE

      Span_Node : constant Node_Id := Scope.Table (Scope.Last).Node;

   begin

      End_Labl_Present := False;

      End_Labl := Empty;

      --  Our first task is to scan out the END sequence if one is present.

      --  If none is present, signal by setting End_Type to E_Dummy.

      if Token /= Tok_End then

         End_Type := E_Dummy;

      else

         Save_Scan_State (Scan_State); -- at END

         End_Sloc := Token_Ptr;

         End_Column := Start_Column;

         End_OK := True;

         Scan; -- past END

         --  Set End_Span if expected. note that this will be useless

         --  if we do not have the right ending keyword, but in this

         --  case we have a malformed program anyway, and the setting

         --  of End_Span will simply be unreliable in this case anyway.

         if Present (Span_Node) then

            Set_End_Location (Span_Node, Token_Ptr);

         end if;

         --  Cases of keywords where no label is allowed

         if Token = Tok_Case then

            End_Type := E_Case;

            Scan; -- past CASE

         elsif Token = Tok_If then

            End_Type := E_If;

            Scan; -- past IF

         elsif Token = Tok_Record then

            End_Type := E_Record;

            Scan; -- past RECORD

         elsif Token = Tok_Select then

            End_Type := E_Select;

            Scan; -- past SELECT

         --  Cases which do allow labels

         else

            --  LOOP

            if Token = Tok_Loop then

               Scan; -- past LOOP

               End_Type := E_Loop;

            --  FOR or WHILE allowed (signalling error) to substitute for LOOP

            --  if on the same line as the END

            elsif (Token = Tok_For or else Token = Tok_While)

              and then not Token_Is_At_Start_Of_Line

            then

               Scan; -- past FOR or WHILE

               End_Type := E_Loop;

               End_OK := False;

            --  Cases with no keyword

            else

               End_Type := E_Name;

            end if;

            --  Now see if a name is present

            if Token = Tok_Identifier or else

               Token = Tok_String_Literal or else

               Token = Tok_Operator_Symbol

            then

               if Token_Is_At_Start_Of_Line then

                  Name_On_Separate_Line := True;

                  Save_Scan_State (Name_Scan_State);

               else

                  Name_On_Separate_Line := False;

               end if;

               End_Labl := P_Designator;

               End_Labl_Present := True;

               --  We have now scanned out a name. Here is where we do a check

               --  to catch the cases like:

               --

               --    end loop

               --    X := 3;

               --

               --  where the missing semicolon might make us swallow up the X

               --  as a bogus end label. In a situation like this, where the

               --  apparent name is on a separate line, we accept it only if

               --  it matches the label and is followed by a semicolon.

               if Name_On_Separate_Line then

                  if Token /= Tok_Semicolon or else

                    not Same_Label (End_Labl, Scope.Table (Scope.Last).Labl)

                  then

                     Restore_Scan_State (Name_Scan_State);

                     End_Labl := Empty;

                     End_Labl_Present := False;

                  end if;

               end if;

            --  Here for case of name allowed, but no name present. We will

            --  supply an implicit matching name, with source location set

            --  to the scan location past the END token.

            else

               End_Labl := Scope.Table (Scope.Last).Labl;

               if End_Labl > Empty_Or_Error then

                  --  The task here is to construct a designator from the

                  --  opening label, with the components all marked as not

                  --  from source, and Is_End_Label set in the identifier

                  --  or operator symbol. The location for all components

                  --  is the curent token location.

                  --  Case of child unit name

                  if Nkind (End_Labl) = N_Defining_Program_Unit_Name then

                     Child_End : declare

                        Eref : constant Node_Id :=

                                 Make_Identifier (Token_Ptr,

                                   Chars =>

                                     Chars (Defining_Identifier (End_Labl)));

                        function Copy_Name (N : Node_Id) return Node_Id;

                        --  Copies a selected component or identifier

                        ---------------

                        -- Copy_Name --

                        ---------------

                        function Copy_Name (N : Node_Id) return Node_Id is

                           R : Node_Id;

                        begin

                           if Nkind (N) = N_Selected_Component then

                              return

                                Make_Selected_Component (Token_Ptr,

                                  Prefix        =>

                                    Copy_Name (Prefix (N)),

                                  Selector_Name =>

                                    Copy_Name (Selector_Name (N)));

                           else

                              R :=

                                Make_Identifier (Token_Ptr,

                                  Chars => Chars (N));

                              Set_Comes_From_Source (N, False);

                              return R;

                           end if;

                        end Copy_Name;

                     --  Start of processing for Child_End

                     begin

                        Set_Comes_From_Source (Eref, False);

                        End_Labl :=

                          Make_Designator (Token_Ptr,

                            Name       => Copy_Name (Name (End_Labl)),

                            Identifier => Eref);

                     end Child_End;

                  --  Simple identifier case

                  elsif Nkind (End_Labl) = N_Defining_Identifier

                    or else Nkind (End_Labl) = N_Identifier

                  then

                     End_Labl :=

                       Make_Identifier (Token_Ptr,

                         Chars => Chars (End_Labl));

                  elsif Nkind (End_Labl) = N_Defining_Operator_Symbol

                    or else Nkind (End_Labl) = N_Operator_Symbol

                  then

                     Get_Decoded_Name_String (Chars (End_Labl));

                     End_Labl :=

                       Make_Operator_Symbol (Token_Ptr,

                         Chars  => Chars (End_Labl),

                         Strval => String_From_Name_Buffer);

                  end if;

                  Set_Comes_From_Source (End_Labl, False);

                  End_Labl_Present := False;

                  --  Do style check for missing label

                  if Style_Check

                    and then End_Type = E_Name

                    and then Explicit_Start_Label (Scope.Last)

                  then

                     Style.No_End_Name (Scope.Table (Scope.Last).Labl);

                  end if;

               end if;

            end if;

         end if;

         --  Except in case of END RECORD, semicolon must follow. For END

         --  RECORD, a semicolon does follow, but it is part of a higher level

         --  construct. In any case, a missing semicolon is not serious enough

         --  to consider the END statement to be bad in the sense that we

         --  are dealing with (i.e. to be suspicious that it is not in fact

         --  the END statement we are looking for!)

         if End_Type /= E_Record then

            if Token = Tok_Semicolon then

               T_Semicolon;

            --  Semicolon is missing. If the missing semicolon is at the end

            --  of the line, i.e. we are at the start of the line now, then

            --  a missing semicolon gets flagged, but is not serious enough

            --  to consider the END statement to be bad in the sense that we

            --  are dealing with (i.e. to be suspicious that this END is not

            --  the END statement we are looking for).

            --  Similarly, if we are at a colon, we flag it but a colon for

            --  a semicolon is not serious enough to consider the END to be

            --  incorrect. Same thing for a period in place of a semicolon.

            elsif Token_Is_At_Start_Of_Line

              or else Token = Tok_Colon

              or else Token = Tok_Dot

            then

               T_Semicolon;

            --  If the missing semicolon is not at the start of the line,

            --  then we do consider the END line to be dubious in this sense.

            else

               End_OK := False;

            end if;

         end if;

      end if;

      --  Now we call the Pop_End_Context routine to get a recommendation

      --  as to what should be done with the END sequence we have scanned.

      Pop_End_Context;

      --  Remaining action depends on End_Action set by Pop_End_Context

      case End_Action is

         --  Accept_As_Scanned. In this case, Pop_End_Context left Token

         --  pointing past the last token of a syntactically correct END

         when Accept_As_Scanned =>

            --  Syntactically correct included the possibility of a missing

            --  semicolon. If we do have a missing semicolon, then we have

            --  already given a message, but now we scan out possible rubbish

            --  on the same line as the END

            while not Token_Is_At_Start_Of_Line

              and then Prev_Token /= Tok_Record

              and then Prev_Token /= Tok_Semicolon

              and then Token /= Tok_End

              and then Token /= Tok_EOF

            loop

               Scan; -- past junk

            end loop;

            return True;

         --  Insert_And_Accept. In this case, Pop_End_Context has reset Token

         --  to point to the start of the END sequence, and recommends that it

         --  be left in place to satisfy an outer scope level END. This means

         --  that we proceed as though an END were present, and leave the scan

         --  pointer unchanged.

         when Insert_And_Accept =>

            return True;

         --  Skip_And_Accept. In this case, Pop_End_Context has reset Token

         --  to point to the start of the END sequence. This END sequence is

         --  syntactically incorrect, and an appropriate error message has

         --  already been posted. Pop_End_Context recommends accepting the

         --  END sequence as the one we want, so we skip past it and then

         --  proceed as though an END were present.

         when Skip_And_Accept =>

            End_Skip;

            return True;

         --  Skip_And_Reject. In this case, Pop_End_Context has reset Token

         --  to point to the start of the END sequence. This END sequence is

         --  syntactically incorrect, and an appropriate error message has

         --  already been posted. Pop_End_Context recommends entirely ignoring

         --  this END sequence, so we skip past it and then return False, since

         --  as far as the caller is concerned, no END sequence is present.

         when Skip_And_Reject =>

            End_Skip;

            return False;

      end case;

   end Check_End;

   --------------

   -- End Skip --

   --------------

   --  This procedure skips past an END sequence. On entry Token contains

   --  Tok_End, and we know that the END sequence is syntactically incorrect,

   --  and that an appropriate error message has already been posted. The

   --  mission is simply to position the scan pointer to be the best guess of

   --  the position after the END sequence. We do not issue any additional

   --  error messages while carrying this out.

   --  Error recovery: does not raise Error_Resync

   procedure End_Skip is

   begin

      Scan; -- past END

      --  If the scan past the END leaves us on the next line, that's probably

      --  where we should quit the scan, since it is likely that what we have

      --  is a missing semicolon. Consider the following:

      --       END

      --       Process_Input;

      --  This will have looked like a syntactically valid END sequence to the

      --  initial scan of the END, but subsequent checking will have determined

      --  that the label Process_Input is not an appropriate label. The real

      --  error is a missing semicolon after the END, and by leaving the scan

      --  pointer just past the END, we will improve the error recovery.

      if Token_Is_At_Start_Of_Line then

         return;

      end if;

      --  If there is a semicolon after the END, scan it out and we are done

      if Token = Tok_Semicolon then

         T_Semicolon;

         return;

      end if;

      --  Otherwise skip past a token after the END on the same line. Note

      --  that we do not eat a token on the following line since it seems

      --  very unlikely in any case that the END gets separated from its

      --  token, and we do not want to swallow up a keyword that starts a

      --  legitimate construct following the bad END.

      if not Token_Is_At_Start_Of_Line

        and then

         --  Cases of normal tokens following an END

          (Token = Tok_Case   or else

           Token = Tok_For    or else

           Token = Tok_If     or else

           Token = Tok_Loop   or else

           Token = Tok_Record or else

           Token = Tok_Select or else

         --  Cases of bogus keywords ending loops

           Token = Tok_For    or else

           Token = Tok_While  or else

         --  Cases of operator symbol names without quotes

           Token = Tok_Abs    or else

           Token = Tok_And    or else

           Token = Tok_Mod    or else

           Token = Tok_Not    or else

           Token = Tok_Or     or else

           Token = Tok_Xor)

      then

         Scan; -- past token after END

         --  If that leaves us on the next line, then we are done. This is the

         --  same principle described above for the case of END at line end

         if Token_Is_At_Start_Of_Line then

            return;

         --  If we just scanned out record, then we are done, since the

         --  semicolon after END RECORD is not part of the END sequence

         elsif Prev_Token = Tok_Record then

            return;

         --  If we have a semicolon, scan it out and we are done

         elsif Token = Tok_Semicolon then

            T_Semicolon;

            return;

         end if;

      end if;

      --  Check for a label present on the same line

      loop

         if Token_Is_At_Start_Of_Line then

            return;

         end if;

         if Token /= Tok_Identifier

           and then Token /= Tok_Operator_Symbol

           and then Token /= Tok_String_Literal

         then

            exit;

         end if;

         Scan; -- past identifier, operator symbol or string literal

         if Token_Is_At_Start_Of_Line then

            return;

         elsif Token = Tok_Dot then

            Scan; -- past dot

         end if;

      end loop;

      --  Skip final semicolon

      if Token = Tok_Semicolon then

         T_Semicolon;

      --  If we don't have a final semicolon, skip until we either encounter

      --  an END token, or a semicolon or the start of the next line. This

      --  allows general junk to follow the end line (normally it is hard to

      --  think that anyone will put anything deliberate here, and remember

      --  that we know there is a missing semicolon in any case). We also

      --  quite on an EOF (or else we would get stuck in an infinite loop

      --  if there is no line end at the end of the last line of the file)

      else

         while Token /= Tok_End

           and then Token /= Tok_EOF

           and then Token /= Tok_Semicolon

           and then not Token_Is_At_Start_Of_Line

         loop

            Scan; -- past junk token on same line

         end loop;

      end if;

      return;

   end End_Skip;

   --------------------

   -- End Statements --

   --------------------

   --  This procedure is called when END is required or expected to terminate

   --  a sequence of statements. The caller has already made an appropriate

   --  entry on the scope stack to describe the expected form of the END.

   --  End_Statements should only be used in cases where the only appropriate

   --  terminator is END.

   --  Error recovery: cannot raise Error_Resync;

   procedure End_Statements (Parent : Node_Id := Empty) is

   begin

      --  This loop runs more than once in the case where Check_End rejects

      --  the END sequence, as indicated by Check_End returning False.

      loop

         if Check_End then

            if Present (Parent) then

               Set_End_Label (Parent, End_Labl);

            end if;

            return;

         end if;

         --  Extra statements past the bogus END are discarded. This is not

         --  ideal for maximum error recovery, but it's too much trouble to

         --  find an appropriate place to put them!

         Discard_Junk_List (P_Sequence_Of_Statements (SS_None));

      end loop;

   end End_Statements;

   ------------------------

   -- Evaluate End Entry --

   ------------------------

   procedure Evaluate_End_Entry (SS_Index : Nat) is

   begin

      Column_OK := (End_Column = Scope.Table (SS_Index).Ecol);

      Token_OK  := (End_Type = Scope.Table (SS_Index).Etyp or else

                     (End_Type = E_Name and then

                       Scope.Table (SS_Index).Etyp >= E_Name));

      Label_OK := End_Labl_Present

                    and then

                      (Same_Label (End_Labl, Scope.Table (SS_Index).Labl)

                        or else Scope.Table (SS_Index).Labl = Error);

      --  Compute setting of Syntax_OK. We definitely have a syntax error

      --  if the Token does not match properly or if P_End_Scan detected

      --  a syntax error such as a missing semicolon.

      if not Token_OK or not End_OK then

         Syntax_OK := False;

      --  Final check is that label is OK. Certainly it is OK if there

      --  was an exact match on the label (the END label = the stack label)

      elsif Label_OK then

         Syntax_OK := True;

      --  Case of label present

      elsif End_Labl_Present then

         --  If probably misspelling, then complain, and pretend it is OK

         declare

            Nam : constant Node_Or_Entity_Id := Scope.Table (SS_Index).Labl;

         begin

            if Nkind (End_Labl) in N_Has_Chars

              and then Comes_From_Source (Nam)

              and then Nkind (Nam) in N_Has_Chars

              and then Chars (End_Labl) > Error_Name

              and then Chars (Nam) > Error_Name

            then

               Get_Name_String (Chars (End_Labl));

               Error_Msg_Name_1 := Chars (Nam);

               if Error_Msg_Name_1 > Error_Name then

                  declare

                     S : constant String (1 .. Name_Len) :=

                           Name_Buffer (1 .. Name_Len);

                  begin

                     Get_Name_String (Error_Msg_Name_1);

                     if Is_Bad_Spelling_Of

                         (Name_Buffer (1 .. Name_Len), S)

                     then

                        Error_Msg_N ("misspelling of %", End_Labl);

                        Syntax_OK := True;

                        return;

                     end if;

                  end;

               end if;

            end if;

         end;

         Syntax_OK := False;

      --  Otherwise we have cases of no label on the END line. For the loop

      --  case, this is acceptable only if the loop is unlabeled.

      elsif End_Type = E_Loop then

         Syntax_OK := not Explicit_Start_Label (SS_Index);

      --  Cases where a label is definitely allowed on the END line

      elsif End_Type = E_Name then

         Syntax_OK := (not Explicit_Start_Label (SS_Index))

                         or else

                      (not Scope.Table (SS_Index).Lreq);

      --  Otherwise we have cases which don't allow labels anyway, so we

      --  certainly accept an END which does not have a label.

      else

         Syntax_OK := True;

      end if;

   end Evaluate_End_Entry;

   --------------------------

   -- Explicit_Start_Label --

   --------------------------

   function Explicit_Start_Label (SS_Index : Nat) return Boolean is

      L : constant Node_Id := Scope.Table (SS_Index).Labl;

   begin

      if No (L) then

         return False;

      elsif Comes_From_Source (L) then

         return True;

      else

         return False;

      end if;

   end Explicit_Start_Label;

   ------------------------

   -- Output End Deleted --

   ------------------------

   procedure Output_End_Deleted is

   begin

      if End_Type = E_Loop then

         Error_Msg_SC ("no LOOP for this `END LOOP`!");

      elsif End_Type = E_Case then

         Error_Msg_SC ("no CASE for this `END CASE`");

      elsif End_Type = E_If then

         Error_Msg_SC ("no IF for this `END IF`!");

      elsif End_Type = E_Record then

         Error_Msg_SC ("no RECORD for this `END RECORD`!");

      elsif End_Type = E_Select then

         Error_Msg_SC ("no SELECT for this `END SELECT`!");

      else

         Error_Msg_SC ("no BEGIN for this END!");

      end if;

   end Output_End_Deleted;

   -------------------------

   -- Output End Expected --

   -------------------------

   procedure Output_End_Expected (Ins : Boolean) is

      End_Type : SS_End_Type;

   begin

      --  Suppress message if this was a potentially junk entry (e.g. a