home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / par-labl.adb < prev    next >
Text File  |  1996-09-28  |  4KB  |  97 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                             P A R . L A B L                              --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.9 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. separate (Par)
  26. procedure Labl is
  27.    Parent_Node : Node_Id;
  28.    --  Used to climb up parents of label node
  29.  
  30.    Label_Decl_Node : Node_Id;
  31.    --  Implicit label declaration node
  32.  
  33.    Defining_Ident_Node : Node_Id;
  34.    --  Defining identifier node for implicit label declaration
  35.  
  36.    Next_Label_Elmt : Elmt_Id;
  37.    --  Next element on label element list
  38.  
  39.    Label_Node : Node_Id;
  40.    --  Next label node to process
  41.  
  42. begin
  43.    Next_Label_Elmt := First_Elmt (Label_List);
  44.  
  45.    while Present (Next_Label_Elmt) loop
  46.       Label_Node := Node (Next_Label_Elmt);
  47.  
  48.       --  Climb parents until we find the closest enclosing body or block
  49.       --  containing a declarative region
  50.  
  51.       Parent_Node := Parent (Label_Node);
  52.  
  53.       while Present (Parent_Node)
  54.         and then Nkind (Parent_Node) /= N_Entry_Body
  55.         and then Nkind (Parent_Node) /= N_Task_Body
  56.         and then Nkind (Parent_Node) /= N_Package_Body
  57.         and then Nkind (Parent_Node) /= N_Subprogram_Body
  58.         and then Nkind (Parent_Node) /= N_Block_Statement
  59.       loop
  60.          Parent_Node := Parent (Parent_Node);
  61.       end loop;
  62.  
  63.       --  If we didn't find a parent, then the label in question never got
  64.       --  hooked into a reasonable declarative part. This happens only in
  65.       --  error situations, and we simply ignore the entry (we aren't going
  66.       --  to get into the semantics in any case given the error).
  67.  
  68.       if Present (Parent_Node) then
  69.  
  70.          --  Now create the implicit label declaration node and its
  71.          --  corresponding defining identifier. Note that the defining
  72.          --  occurrence of a label is the implicit label declaration that
  73.          --  we are creating. The label itself is an applied occurrence.
  74.  
  75.          Label_Decl_Node
  76.            := New_Node (N_Implicit_Label_Declaration, Sloc (Label_Node));
  77.          Set_Label (Label_Decl_Node, Label_Node);
  78.          Defining_Ident_Node :=
  79.            New_Entity (N_Defining_Identifier, Sloc (Identifier (Label_Node)));
  80.          Set_Chars (Defining_Ident_Node, Chars (Identifier (Label_Node)));
  81.          Set_Defining_Identifier (Label_Decl_Node, Defining_Ident_Node);
  82.  
  83.          --  Now attach the implicit label declaration to the appropriate
  84.          --  declarative region, creating a declaration list if none exists
  85.  
  86.          if not Present (Declarations (Parent_Node)) then
  87.             Set_Declarations (Parent_Node, New_List);
  88.          end if;
  89.  
  90.          Append (Label_Decl_Node, Declarations (Parent_Node));
  91.       end if;
  92.  
  93.       Next_Label_Elmt := Next_Elmt (Next_Label_Elmt);
  94.    end loop;
  95.  
  96. end Labl;
  97.