Disable tests for strdup/strndup on __hpux__

[official-gcc.git] / gcc / ada / par-endh.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             P A R . E N D H                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2023, 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 3,  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 COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Namet.Sp; use Namet.Sp;
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
     (Decl   : Node_Id    := Empty;
      Is_Loc : Source_Ptr := No_Location) 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 := Scopes (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_Return then
            End_Type := E_Return;
            Scan; -- past RETURN

         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 in Tok_For | 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, Scopes (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 := Scopes (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 current 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 (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 (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 label permitted but not present. Note:
                  --  for the case of a block statement, the label is required
                  --  to be repeated, and this legality rule is enforced
                  --  independently.

                  if Style_Check
                    and then End_Type = E_Name
                    and then Explicit_Start_Label (Scope.Last)
                    and then Nkind (Parent (Scopes (Scope.Last).Labl))
                               /= N_Block_Statement
                  then
                     Style.No_End_Name (Scopes (Scope.Last).Labl);
                  end if;
               end if;
            end if;
         end if;

         --  Deal with terminating aspect specifications and following semi-
         --  colon. We skip this in the case of END RECORD, since in this
         --  case the aspect specifications and semicolon are handled at
         --  a higher level.

         if End_Type /= E_Record then

            --  Scan aspect specifications

            if Aspect_Specifications_Present then

               --  Aspect specifications not allowed

               if No (Decl) then

                  --  Package declaration case

                  if Is_Loc /= No_Location then
                     Error_Msg_SC
                       ("misplaced aspects for package declaration");
                     Error_Msg
                       ("info: aspect specifications belong here??", Is_Loc);
                     P_Aspect_Specifications (Empty);

                  --  Other cases where aspect specifications are not allowed

                  else
                     P_Aspect_Specifications (Error);
                  end if;

               --  Aspect specifications allowed

               else
                  P_Aspect_Specifications (Decl);
               end if;

            --  If no aspect specifications, must have a semicolon

            elsif 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 in Tok_Colon | Tok_Dot
               then
                  T_Semicolon;

               --  If the missing semicolon is not at the start of the line,
               --  then we consider the END line to be dubious in this sense.

               else
                  End_OK := False;
               end if;
            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 not in Tok_Record | Tok_Semicolon
              and then Token not in Tok_End | 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_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 not in
           Tok_Identifier | Tok_Operator_Symbol | 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 not in Tok_End | Tok_EOF | 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;
      Decl    : Node_Id    := Empty;
      Is_Sloc : Source_Ptr := No_Location)
   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 (Decl, Is_Sloc) 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
      STE : Scope_Table_Entry renames Scopes (SS_Index).all;

   begin
      Column_OK := (End_Column = STE.Ecol);

      Token_OK  := (End_Type = STE.Etyp
                     or else (End_Type = E_Name and then STE.Etyp >= E_Name));

      Label_OK := End_Labl_Present
                    and then (Same_Label (End_Labl, STE.Labl)
                               or else STE.Labl = Error);

      --  Special case to consider. Suppose we have the suspicious label case,
      --  e.g. a situation like:

      --    My_Label;
      --    declare
      --       ...
      --    begin
      --       ...
      --    end My_Label;

      --  This is the case where we want to use the entry in the suspicious
      --  label table to flag the semicolon saying it should be a colon.

      --  Label_OK will be false because the label does not match (we have
      --  My_Label on the end line, and the generated name for the scope). Also
      --  End_Labl_Present will be True.

      if not Label_OK
        and then End_Labl_Present
        and then not Comes_From_Source (Scopes (SS_Index).Labl)
      then
         --  Here is where we will search the suspicious labels table

         for J in 1 .. Suspicious_Labels.Last loop
            declare
               SLE : Suspicious_Label_Entry renames
                       Suspicious_Labels.Table (J);
            begin
               --  See if character name of label matches

               if Chars (Name (SLE.Proc_Call)) = Chars (End_Labl)

                 --  And first token of loop/block identifies this entry

                 and then SLE.Start_Token = STE.Sloc
               then
                  --  We have the special case, issue the error message

                  Error_Msg -- CODEFIX
                    (""";"" should be "":""", SLE.Semicolon_Loc);

                  --  And indicate we consider the Label OK after all

                  Label_OK := True;
                  exit;
               end if;
            end;
         end loop;
      end if;

      --  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 := Scopes (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
               Error_Msg_Name_1 := Chars (Nam);

               if Error_Msg_Name_1 > Error_Name then
                  if Is_Bad_Spelling_Of (Chars (Nam), Chars (End_Labl)) then
                     Error_Msg_Name_1 := Chars (Nam);
                     Error_Msg_N -- CODEFIX
                       ("misspelling of %", End_Labl);
                     Syntax_OK := True;
                     return;
                  end if;
               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 Scopes (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 := Scopes (SS_Index).Labl;
      Etyp : constant SS_End_Type := Scopes (SS_Index).Etyp;

   begin
      if No (L) then
         return False;

      --  In the following test we protect the call to Comes_From_Source
      --  against lines containing previously reported syntax errors.

      elsif (Etyp = E_Loop          or else
             Etyp = E_Name          or else
             Etyp = E_Suspicious_Is or else
             Etyp = E_Bad_Is)
         and then 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_Return then
         Error_Msg_SC ("no RETURN for this `END RETURN`!");

      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 record
      --  entry where no record keyword was present).

      if Scopes (Scope.Last).Junk then
         return;
      end if;

      End_Type := Scopes (Scope.Last).Etyp;
      Error_Msg_Col  := Scopes (Scope.Last).Ecol;
      Error_Msg_Sloc := Scopes (Scope.Last).Sloc;

      if Explicit_Start_Label (Scope.Last) then
         Error_Msg_Node_1 := Scopes (Scope.Last).Labl;
      else
         Error_Msg_Node_1 := Empty;
      end if;

      --  Suppress message if error was posted on opening label

      if Error_Msg_Node_1 > Empty_Or_Error
        and then Error_Posted (Error_Msg_Node_1)
      then
         return;
      end if;

      if End_Type = E_Case then
         Error_Msg_SC -- CODEFIX
           ("`END CASE;` expected@ for CASE#!");

      elsif End_Type = E_If then
         Error_Msg_SC -- CODEFIX
           ("`END IF;` expected@ for IF#!");

      elsif End_Type = E_Loop then
         if Error_Msg_Node_1 = Empty then
            Error_Msg_SC -- CODEFIX
              ("`END LOOP;` expected@ for LOOP#!");
         else
            Error_Msg_SC -- CODEFIX
              ("`END LOOP &;` expected@!");
         end if;

      elsif End_Type = E_Record then
         Error_Msg_SC -- CODEFIX
           ("`END RECORD;` expected@ for RECORD#!");

      elsif End_Type = E_Return then
         Error_Msg_SC -- CODEFIX
           ("`END RETURN;` expected@ for RETURN#!");

      elsif End_Type = E_Select then
         Error_Msg_SC -- CODEFIX
           ("`END SELECT;` expected@ for SELECT#!");

      --  All remaining cases are cases with a name (we do not treat the
      --  suspicious is cases specially for a replaced end, only for an
      --  inserted end).

      elsif End_Type = E_Name or else not Ins then
         if Error_Msg_Node_1 = Empty then
            Error_Msg_SC -- CODEFIX
              ("`END;` expected@ for BEGIN#!");
         else
            Error_Msg_SC -- CODEFIX
              ("`END &;` expected@!");
         end if;

      --  The other possibility is a missing END for a subprogram with a
      --  suspicious IS (that probably should have been a semicolon). The
      --  missing IS confirms the suspicion.

      else -- End_Type = E_Suspicious_Is or E_Bad_Is
         Scopes (Scope.Last).Etyp := E_Bad_Is;
      end if;
   end Output_End_Expected;

   ------------------------
   -- Output_End_Missing --
   ------------------------

   procedure Output_End_Missing is
      End_Type : SS_End_Type;

   begin
      --  Suppress message if this was a potentially junk entry (e.g. a record
      --  entry where no record keyword was present).

      if Scopes (Scope.Last).Junk then
         return;
      end if;

      End_Type := Scopes (Scope.Last).Etyp;
      Error_Msg_Sloc   := Scopes (Scope.Last).Sloc;

      if Explicit_Start_Label (Scope.Last) then
         Error_Msg_Node_1 := Scopes (Scope.Last).Labl;
      else
         Error_Msg_Node_1 := Empty;
      end if;

      if End_Type = E_Case then
         Error_Msg_BC ("missing `END CASE;` for CASE#!");

      elsif End_Type = E_If then
         Error_Msg_BC ("missing `END IF;` for IF#!");

      elsif End_Type = E_Loop then
         if Error_Msg_Node_1 = Empty then
            Error_Msg_BC ("missing `END LOOP;` for LOOP#!");
         else
            Error_Msg_BC ("missing `END LOOP &;`!");
         end if;

      elsif End_Type = E_Record then
         Error_Msg_SC
           ("missing `END RECORD;` for RECORD#!");

      elsif End_Type = E_Return then
         Error_Msg_SC
           ("missing `END RETURN;` for RETURN#!");

      elsif End_Type = E_Select then
         Error_Msg_BC
           ("missing `END SELECT;` for SELECT#!");

      elsif End_Type = E_Name then
         if Error_Msg_Node_1 = Empty then
            Error_Msg_BC ("missing `END;` for BEGIN#!");
         else
            Error_Msg_BC ("missing `END &;`!");
         end if;

      else -- End_Type = E_Suspicious_Is or E_Bad_Is
         Scopes (Scope.Last).Etyp := E_Bad_Is;
      end if;
   end Output_End_Missing;

   ---------------------
   -- Pop_End_Context --
   ---------------------

   procedure Pop_End_Context is

      Pretty_Good : Boolean;
      --  This flag is set True if the END sequence is syntactically incorrect,
      --  but is (from a heuristic point of view), pretty likely to be simply
      --  a misspelling of the intended END.

      Outer_Match : Boolean;
      --  This flag is set True if we decide that the current END sequence
      --  belongs to some outer level entry in the scope stack, and thus
      --  we will NOT eat it up in matching the current expected END.

   begin
      --  If not at END, then output END expected message

      if End_Type = E_Dummy then
         Output_End_Missing;
         Pop_Scope_Stack;
         End_Action := Insert_And_Accept;
         return;

      --  Otherwise we do have an END present

      else
         --  A special check. If we have END; followed by an end of file,
         --  WITH or SEPARATE, then if we are not at the outer level, then
         --  we have a syntax error. Consider the example:

         --   ...
         --      declare
         --         X : Integer;
         --      begin
         --         X := Father (A);
         --         Process (X, X);
         --   end;
         --   with Package1;
         --   ...

         --  Now the END; here is a syntactically correct closer for the
         --  declare block, but if we eat it up, then we obviously have
         --  a missing END for the outer context (since WITH can only appear
         --  at the outer level.

         --  In this situation, we always reserve the END; for the outer level,
         --  even if it is in the wrong column. This is because it's much more
         --  useful to have the error message point to the DECLARE than to the
         --  package header in this case.

         --  We also reserve an end with a name before the end of file if the
         --  name is the one we expect at the outer level.

         if (Token = Tok_EOF  or else
             Token = Tok_With or else
             Token = Tok_Separate)
           and then End_Type >= E_Name
           and then (not End_Labl_Present
                      or else Same_Label (End_Labl, Scopes (1).Labl))
           and then Scope.Last > 1
         then
            Restore_Scan_State (Scan_State); -- to END
            Output_End_Expected (Ins => True);
            Pop_Scope_Stack;
            End_Action := Insert_And_Accept;
            return;
         end if;

         --  Otherwise we go through the normal END evaluation procedure

         Evaluate_End_Entry (Scope.Last);

         --  If top entry in stack is syntactically correct, then we have
         --  scanned it out and everything is fine. This is the required
         --  action to properly process correct Ada programs.

         if Syntax_OK then

            --  Complain if checking columns and END is not in right column.
            --  Right in this context means exactly right, or on the same
            --  line as the opener.

            if RM_Column_Check then
               if End_Column /= Scopes (Scope.Last).Ecol
                 and then Current_Line_Start > Scopes (Scope.Last).Sloc

               --  A special case, for END RECORD, we are also allowed to
               --  line up with the TYPE keyword opening the declaration.

                 and then (Scopes (Scope.Last).Etyp /= E_Record
                            or else Get_Column_Number (End_Sloc) /=
                                    Get_Column_Number (Type_Token_Location))
               then
                  Error_Msg_Col := Scopes (Scope.Last).Ecol;
                  Error_Msg
                    ("(style) END in wrong column, should be@?l?", End_Sloc);
               end if;
            end if;

            --  One final check. If the end had a label, check for an exact
            --  duplicate of this end sequence, and if so, skip it with an
            --  appropriate message.

            if End_Labl_Present and then Token = Tok_End then
               declare
                  Scan_State : Saved_Scan_State;
                  End_Loc    : constant Source_Ptr := Token_Ptr;
                  Nxt_Labl   : Node_Id;
                  Dup_Found  : Boolean := False;

               begin
                  Save_Scan_State (Scan_State);

                  Scan; -- past END

                  if Token in Tok_Identifier | Tok_Operator_Symbol then
                     Nxt_Labl := P_Designator;

                     --  We only consider it an error if the label is a match
                     --  and would be wrong for the level one above us, and
                     --  the indentation is the same.

                     if Token = Tok_Semicolon
                       and then Same_Label (End_Labl, Nxt_Labl)
                       and then End_Column = Start_Column
                       and then
                         (Scope.Last = 1
                            or else
                              not Explicit_Start_Label (Scope.Last - 1)
                                 or else
                              not Same_Label
                                    (End_Labl,
                                     Scopes (Scope.Last - 1).Labl))
                     then
                        T_Semicolon;
                        Error_Msg ("duplicate end line ignored", End_Loc);
                        Dup_Found := True;
                     end if;
                  end if;

                  if not Dup_Found then
                     Restore_Scan_State (Scan_State);
                  end if;
               end;
            end if;

            --  All OK, so return to caller indicating END is OK

            Pop_Scope_Stack;
            End_Action := Accept_As_Scanned;
            return;
         end if;

         --  If that check failed, then we definitely have an error. The issue
         --  is how to choose among three possible courses of action:

         --   1. Ignore the current END text completely, scanning past it,
         --      deciding that it belongs neither to the current context,
         --      nor to any outer context.

         --   2. Accept the current END text, scanning past it, and issuing
         --      an error message that it does not have the right form.

         --   3. Leave the current END text in place, NOT scanning past it,
         --      issuing an error message indicating the END expected for the
         --      current context. In this case, the END is available to match
         --      some outer END context.

         --  From a correct functioning point of view, it does not make any
         --  difference which of these three approaches we take, the program
         --  will work correctly in any case. However, making an accurate
         --  choice among these alternatives, i.e. choosing the one that
         --  corresponds to what the programmer had in mind, does make a
         --  significant difference in the quality of error recovery.

         Restore_Scan_State (Scan_State); -- to END

         --  First we see how good the current END entry is with respect to
         --  what we expect. It is considered pretty good if the token is OK,
         --  and either the label or the column matches. An END for RECORD is
         --  always considered to be pretty good in the record case. This is
         --  because not only does a record disallow a nested structure, but
         --  also it is unlikely that such nesting could occur by accident.

         Pretty_Good := (Token_OK and (Column_OK or Label_OK))
                          or else Scopes (Scope.Last).Etyp = E_Record;

         --  Next check, if there is a deeper entry in the stack which
         --  has a very high probability of being acceptable, then insert
         --  the END entry we want, leaving the higher level entry for later

         for J in reverse 1 .. Scope.Last - 1 loop
            Evaluate_End_Entry (J);

            --  To even consider the deeper entry to be immediately acceptable,
            --  it must be syntactically correct. Furthermore it must either
            --  have a correct label, or the correct column. If the current
            --  entry was a close match (Pretty_Good set), then we are even
            --  more strict in accepting the outer level one: even if it has
            --  the right label, it must have the right column as well.

            if Syntax_OK then
               if Pretty_Good then
                  Outer_Match := Label_OK and Column_OK;
               else
                  Outer_Match := Label_OK or Column_OK;
               end if;
            else
               Outer_Match := False;
            end if;

            --  If the outer entry does convincingly match the END text, then
            --  back up the scan to the start of the END sequence, issue an
            --  error message indicating the END we expected, and return with
            --  Token pointing to the END (case 3 from above discussion).

            if Outer_Match then
               Output_End_Missing;
               Pop_Scope_Stack;
               End_Action := Insert_And_Accept;
               return;
            end if;
         end loop;

         --  Here we have a situation in which the current END entry is
         --  syntactically incorrect, but there is no deeper entry in the
         --  END stack which convincingly matches it.

         --  If the END text was judged to be a Pretty_Good match for the
         --  expected token or if it appears left of the expected column,
         --  then we will accept it as the one we want, scanning past it, even
         --  though it is not completely right (we issue a message showing what
         --  we expected it to be). This is action 2 from the discussion above.
         --  There is one other special case to consider: the LOOP case.
         --  Consider the example:

         --     Lbl: loop
         --             null;
         --          end loop;

         --  Here the column lines up with Lbl, so END LOOP is to the right,
         --  but it is still acceptable. LOOP is the one case where alignment
         --  practices vary substantially in practice.

         if Pretty_Good
            or else End_Column <= Scopes (Scope.Last).Ecol
            or else (End_Type = Scopes (Scope.Last).Etyp
                        and then End_Type = E_Loop)
         then
            Output_End_Expected (Ins => False);
            Pop_Scope_Stack;
            End_Action := Skip_And_Accept;
            return;

         --  Here we have the case where the END is to the right of the
         --  expected column and does not have a correct label to convince
         --  us that it nevertheless belongs to the current scope. For this
         --  we consider that it probably belongs not to the current context,
         --  but to some inner context that was not properly recognized (due to
         --  other syntax errors), and for which no proper scope stack entry
         --  was made. The proper action in this case is to delete the END text
         --  and return False to the caller as a signal to keep on looking for
         --  an acceptable END. This is action 1 from the discussion above.

         else
            Output_End_Deleted;
            End_Action := Skip_And_Reject;
            return;
         end if;
      end if;
   end Pop_End_Context;

   ----------------
   -- Same_Label --
   ----------------

   function Same_Label (Label1, Label2 : Node_Id) return Boolean is
   begin
      if Nkind (Label1) in N_Has_Chars
        and then Nkind (Label2) in N_Has_Chars
      then
         return Chars (Label1) = Chars (Label2);

      elsif Nkind (Label1) = N_Selected_Component
        and then Nkind (Label2) = N_Selected_Component
      then
         return Same_Label (Prefix (Label1), Prefix (Label2)) and then
           Same_Label (Selector_Name (Label1), Selector_Name (Label2));

      elsif Nkind (Label1) = N_Designator
        and then Nkind (Label2) = N_Defining_Program_Unit_Name
      then
         return Same_Label (Name (Label1), Name (Label2)) and then
           Same_Label (Identifier (Label1), Defining_Identifier (Label2));

      else
         return False;
      end if;
   end Same_Label;

end Endh;